Index: bindings/ruby/lib/mooix/thing.rb
===================================================================
--- bindings/ruby/lib/mooix/thing.rb (revision 23)
+++ bindings/ruby/lib/mooix/thing.rb (working copy)
@@ -343,47 +343,47 @@
lock
end
-=begin
---- Thing.prettyname
-Returns a name suitable for pretty-printing. Adds an article if one is defined, else adds nothing.
- :Returns:
- pretty-printable name for this.
-=end
-
- def prettyname
- if self.has?("article") and self.article != nil
- return "#{article} #{name}"
- else
- return "#{name}"
- end
- end
-
-=begin
---- Thing.prettylist(objects)
-Prepares ((|objects|)) for pretty-printing.
- :Parameters:
- : ((|objects|))
- list of objects or strings whose value is to be pretty-printed.
- :Returns:
- string listing all objects and strings contained within ((|objects|)) in a format suitable for printing.
-=end
-
- def prettylist(objects)
- return "nothing" if objects.length == 0
- result = ""
- objects.each_index do |x|
- if objects[x] == self
- result += "you"
- else
- if objects[x].class != String
- result += "#{objects[x].prettyname}"
- else
- result += "#{objects[x]}"
- end
- end
- result += ", " if x <= (objects.length-3)
- result += " and " if x == (objects.length-2)
- end
- return result
- end
+## =begin
+## --- Thing.prettyname
+## Returns a name suitable for pretty-printing. Adds an article if one is defined, else adds nothing.
+## :Returns:
+## pretty-printable name for this.
+## =end
+##
+## def prettyname
+## if self.has?("article") and self.article != nil
+## return "#{article} #{name}"
+## else
+## return "#{name}"
+## end
+## end
+##
+## =begin
+## --- Thing.prettylist(objects)
+## Prepares ((|objects|)) for pretty-printing.
+## :Parameters:
+## : ((|objects|))
+## list of objects or strings whose value is to be pretty-printed.
+## :Returns:
+## string listing all objects and strings contained within ((|objects|)) in a format suitable for printing.
+## =end
+##
+## def prettylist(objects)
+## return "nothing" if objects.length == 0
+## result = ""
+## objects.each_index do |x|
+## if objects[x] == self
+## result += "you"
+## else
+## if objects[x].class != String
+## result += "#{objects[x].prettyname}"
+## else
+## result += "#{objects[x]}"
+## end
+## end
+## result += ", " if x <= (objects.length-3)
+## result += " and " if x == (objects.length-2)
+## end
+## return result
+## end
end
Index: bindings/python/mooix/variables.py
===================================================================
--- bindings/python/mooix/variables.py (revision 23)
+++ bindings/python/mooix/variables.py (working copy)
@@ -24,7 +24,7 @@
# this gets set at compile time
try:
- MOOROOT = MOOROOT_FROM_BUILD
+ MOOROOT = '/var/lib/mooix'
except NameError:
MOOROOT = None
Index: bindings/python/mooix/Thing.py
===================================================================
--- bindings/python/mooix/Thing.py (revision 23)
+++ bindings/python/mooix/Thing.py (working copy)
@@ -31,8 +31,8 @@
"""A generic exception for something going wrong."""
pass
-def _prettyname(thing):
- return (thing.article and '%s ' % thing.article) + thing.name
+## def _prettyname(thing):
+## return (thing.article and '%s ' % thing.article) + thing.name
class Thing(object):
"""This is the mooix object class for Python. It provides a standard class
@@ -437,24 +437,24 @@
stacklevel = 2)
return None
- def prettyname(self):
- """prettyname() -> the object's name with any article prepended"""
- return _prettyname(self)
+## def prettyname(self):
+## """prettyname() -> the object's name with any article prepended"""
+## return _prettyname(self)
+##
+## def prettylist(self, object_list):
+## """prettylist(object_list) -> a pretty-printed list of objects
+##
+## Generates a very pretty-printed list of objects, and returns it.
+## The object it's run on will appear in the list as "you"."""
+## object_list = tolist(object_list)
+## if object_list:
+## return (len(object_list) > 2
+## and ', '
+## or ' and ').join([ _prettyname(o)
+## for o in object_list
+## if isinstance(o, Thing) ])
+## else:
+## return 'nothing'
- def prettylist(self, object_list):
- """prettylist(object_list) -> a pretty-printed list of objects
- Generates a very pretty-printed list of objects, and returns it.
- The object it's run on will appear in the list as "you"."""
- object_list = tolist(object_list)
- if object_list:
- return (len(object_list) > 2
- and ', '
- or ' and ').join([ _prettyname(o)
- for o in object_list
- if isinstance(o, Thing) ])
- else:
- return 'nothing'
-
-
__all__ = [ 'MooixError', 'Thing', 'LOCK_UN', 'LOCK_SH', 'LOCK_EX', 'LOCK_NB' ]
Index: bindings/perl/lib/Mooix/Thing.pm
===================================================================
--- bindings/perl/lib/Mooix/Thing.pm (revision 23)
+++ bindings/perl/lib/Mooix/Thing.pm (working copy)
@@ -90,8 +90,9 @@
Mooix::Thing also exports into your namespace a function called "fail". This
function can be used by verbs (and occasional other methods) to exit with a
-numeric exit code that indicates failure, and at the same time return a value
-to the caller.
+numeric exit code that indicates failure. It takes no arguments.
+Before running it, you should use $this->msg() to let the user know
+what happened.
=cut
@@ -118,7 +119,10 @@
# no strict 'refs';
*debuglog = *_debuglog_null;
*{"${callpkg}::fail"} = sub {
- print join("\n",map { "\"$_\"" } @_)."\n";
+ if( @_ )
+ {
+ print "UNTRANTSLATED FAIL MESSAGE!: ". join("\n",map { "\"$_\"" } @_)."\n";
+ }
exit 10; # FAIL
};
*{"${callpkg}::run"} = sub {
@@ -733,36 +737,45 @@
return 1;
}
-=item prettylist
+## =item prettylist
+##
+## Generates a very pretty-printed list of objects, and returns it. The
+## object it's run on will appear in the list as "you".
+##
+## =cut
+##
+## sub prettylist {
+## my $this=shift;
+## my $avatar=shift;
+## my @objects=@_;
+##
+## # Get the list seperators for this language.
+## my $list_sep = $this->language->list_seperator;
+## my $list_sep_end = $this->language->list_seperator_last;
+##
+## return "nothing" if ! @objects;
+## @objects = map { $_->prettyname( recipient => $this, avatar => $avatar ) }
+## grep ref, @objects;
+## $objects[$#objects] = $list_sep_end . $objects[$#objects] if @objects > 1;
+## return join((@objects > 2) ? $list_sep : '', @objects);
+## }
-Generates a very pretty-printed list of objects, and returns it. The
-object it's run on will appear in the list as "you".
+## =item prettyname
+##
+## Returns the object's name with any article prepended.
+##
+## =cut
+##
+## sub prettyname {
+## my $this=shift;
+## my $avatar=shift;
+## my $a = $this->article;
+## $a.="" if length $a;
+## my $text = $a.$this->name;
+## $text = $this->dexml( avatar => $avatar, text => $text );
+## return $text;
+## }
-=cut
-
-sub prettylist {
- my $this=shift;
- my @objects=@_;
-
- return "nothing" if ! @objects;
- @objects = map { $_ == $this ? 'you' : $_->prettyname }
- grep ref, @objects;
- $objects[$#objects] = 'and '.$objects[$#objects] if @objects > 1;
- return join((@objects > 2) ? ', ' : ' ', @objects);
-}
-
-=item prettyname
-
-Returns the object's name with any article prepended.
-
-=cut
-
-sub prettyname {
- my $a = $_[0]->article;
- $a.=" " if length $a;
- return $a.$_[0]->name;
-}
-
=item untaint
If perl is run with taint checking enabled, and some method returns a mooix
@@ -848,7 +861,11 @@
my $fh;
if (! open ($fh, $file)) {
- $this->croak($file);
+ # Can't use croak here! This is because croak
+ # *itself* does (many) field reads, so infinite
+ # loops can result!
+ ## $this->croak($file);
+ die "Failure in _readfield reading $file.\n";
}
if (wantarray) {
my $sticky=-k _;
Index: bindings/c/moomethod.h
===================================================================
--- bindings/c/moomethod.h (revision 23)
+++ bindings/c/moomethod.h (working copy)
@@ -3,6 +3,14 @@
* It's very incomplete so far. It doesn't try to be pseudo-OO (yet).
*/
+/* For information on how to pass values out, read "help
+ * methods-lowlevel".
+ */
+
+/* To print debugging messages, send stuff to stderr. It's
+ * primitive, but it'll get sent to the calling session.
+ */
+
#include
#include
#include
@@ -65,7 +73,9 @@
* a true value (1) */
int truefield (object *obj, const char *field);
/* Gets and returns a field of the current object. Does not do inheritence,
- * and only returns the first line of the field. */
+ * and only returns the first line of the field. Can be used on the
+ * return value of fieldfile, however, which makes it not entirely
+ * useless. */
char *getfield (const char *field);
/* Sets a field of the current object to a value. Returns true if the set
* succeeds. */
@@ -94,3 +104,27 @@
/* Read a line of any size and return a malloced string, or NULL on eof. */
char *mooix_getline (FILE *f, int killquotes);
+
+/* Generate a prettified name for an object, from the POV of the
+ * recipient. */
+char *prettyname( object *obj, object *recipient );
+
+/* Read all parameters, return NULL terminated array. */
+param **getparams( void );
+
+/* Look up a parameter from an array by name. */
+char *findparam (const char *key, param **params);
+
+/* Remove xml tags from the text. is supported; marked up
+ * in bold down the stream, all else are ignored. Also handle
+ * entities. In the vast majority of cases, uses dexml_recipient,
+ * which is an avatar, to determine the preferred language, but in
+ * some cases (read: parsers), uses the language argument instead.
+ */
+char *dexml( char *text, object *avatar_ptr, char *language );
+
+/* Just like runmethod, but takes a param structure list instead of a bunch of strings */
+FILE *runmethod_param( object *obj, const char *method, param **params );
+
+/* Runs prettyname as though a third-person perspective pertains */
+char *other_prettyname( object *obj, object *recipient );
Index: bindings/c/moomethod.c
===================================================================
--- bindings/c/moomethod.c (revision 23)
+++ bindings/c/moomethod.c (working copy)
@@ -13,400 +13,1197 @@
#include
#include
#include
+#include
+#include
+#include
+
+#include
+
#include "moomethod.h"
int methinit (void) {
- char *dir = getenv("THIS");
- if (dir == NULL)
- return 0;
- return chdir(getenv("THIS"));
+ char *dir = getenv("THIS");
+ if (dir == NULL)
+ return 0;
+ return chdir(getenv("THIS"));
}
void freeparam (param *param) {
- free(param->name);
- free(param->value);
- free(param);
+ free(param->name);
+ free(param->value);
+ free(param);
}
char *mooix_getline (FILE *f, int killquotes) {
- int size = 0;
- char *ret = NULL;
+ int size = 0;
+ char *ret = NULL;
- if (feof(f))
- return NULL;
-
- do {
- ret = realloc(ret, size + 128 + 1);
- if (! fgets(ret + size, 128, f)) {
- if (size == 0) {
- free(ret);
- return NULL; /* reached eof with empty string */
- }
- else {
- ret[size]='\0';
- break;
- }
- }
- size = strlen(ret);
- } while (size > 0 && ret[size - 1] != '\n');
+ if (feof(f))
+ return NULL;
- /* remove trailing newline */
- if (ret[size - 1] == '\n')
- ret[--size] = '\0';
-
- /* Remove quotes? */
- if (killquotes) {
- if (size > 1 && ret[0] == '"' && ret[size - 1] == '"') {
- ret[--size] = '\0';
- memmove(ret, ret + 1, size); /* left shift by one char */
- }
+ do {
+ ret = realloc(ret, size + 128 + 1);
+ if (! fgets(ret + size, 128, f)) {
+ if (size == 0) {
+ free(ret);
+ return NULL; /* reached eof with empty string */
+ }
+ else {
+ ret[size]='\0';
+ break;
+ }
}
- return ret;
+ size = strlen(ret);
+ } while (size > 0 && ret[size - 1] != '\n');
+
+ /* remove trailing newline */
+ if (ret[size - 1] == '\n')
+ ret[--size] = '\0';
+
+ /* Remove quotes? */
+ if (killquotes) {
+ if (size > 1 && ret[0] == '"' && ret[size - 1] == '"') {
+ ret[--size] = '\0';
+ memmove(ret, ret + 1, size); /* left shift by one char */
+ }
+ }
+ return ret;
}
char *getkey () {
- return mooix_getline(stdin, 1);
+ return mooix_getline(stdin, 1);
}
char *escape (const char *s) {
- /* Change embedded newlines to \\n, and double slashes. Add quotes. */
- if (strchr(s, '\n') || strchr(s, '\\')) {
- char *q, *t = malloc(strlen(s) * 2 + 3);
- const char *p;
-
- for (p = s, q = t + 1; p[0] != '\0'; p++, q++) {
- if (p[0] == '\n') {
- q[0] = '\\';
- q[1] = 'n';
- q++;
- }
- else if (p[0] == '\\') {
- q[0] = '\\';
- q[1] = '\\';
- q++;
- }
- else {
- q[0] = p[0];
- }
- }
- t[0] = q[0] = '"';
- q[1] = '\0';
- return t;
+ /* Change embedded newlines to \\n, and double slashes. Add quotes. */
+ if (strchr(s, '\n') || strchr(s, '\\')) {
+ char *q, *t = malloc(strlen(s) * 2 + 3);
+ const char *p;
+
+ for (p = s, q = t + 1; p[0] != '\0'; p++, q++) {
+ if (p[0] == '\n') {
+ q[0] = '\\';
+ q[1] = 'n';
+ q++;
+ }
+ else if (p[0] == '\\') {
+ q[0] = '\\';
+ q[1] = '\\';
+ q++;
+ }
+ else {
+ q[0] = p[0];
+ }
}
- else {
- int len = strlen(s);
- char *t = malloc(len + 3);
- t[0] = '"';
- strcpy(t+1, s);
- t[0] = t[len + 1] = '"';
- t[len + 2] = '\0';
- return t;
- }
+ t[0] = q[0] = '"';
+ q[1] = '\0';
+ return t;
+ }
+ else {
+ int len = strlen(s);
+ char *t = malloc(len + 3);
+ t[0] = '"';
+ strcpy(t+1, s);
+ t[0] = t[len + 1] = '"';
+ t[len + 2] = '\0';
+ return t;
+ }
}
char *unescape (char *s) {
- char *p = s;
-
- while (p && (p = strstr(p, "\\"))) {
- int len = strlen(s);
+ char *p = s;
- if (p[1] == '\\') {
- /* memmove below will remove first slash */
- }
- else if (p[1] == 'n' && (p == s || p[-1] != '\\')) {
- /* Turn "\n" into a literal newline. */
- p[1] = '\n';
- }
- else {
- p++;
- continue;
- }
-
- /* Copy remainder of line over slash. */
- memmove(p, p+1, len - (p - s) + 1);
- p++;
+ while (p && (p = strstr(p, "\\"))) {
+ int len = strlen(s);
+
+ if (p[1] == '\\') {
+ /* memmove below will remove first slash */
}
-
- return s;
+ else if (p[1] == 'n' && (p == s || p[-1] != '\\')) {
+ /* Turn "\n" into a literal newline. */
+ p[1] = '\n';
+ }
+ else {
+ p++;
+ continue;
+ }
+
+ /* Copy remainder of line over slash. */
+ memmove(p, p+1, len - (p - s) + 1);
+ p++;
+ }
+
+ return s;
}
char *fgetvalue (FILE *f) {
- return unescape(mooix_getline(f, 1));
+ return unescape(mooix_getline(f, 1));
}
char *getvalue () {
- return fgetvalue(stdin);
+ return fgetvalue(stdin);
}
char **fgetallvals (FILE *f) {
- int size=16, count=0;
- char **ret=malloc(size * sizeof(char *));
- char *s;
-
- while ((s = fgetvalue(f))) {
- ret[count] = s;
- count++;
- if (count >= size) {
- size *= 2;
- ret = realloc(ret, size * sizeof(char *));
- }
+ int size=16, count=0;
+ char **ret=malloc(size * sizeof(char *));
+ char *s;
+
+ while ((s = fgetvalue(f))) {
+ ret[count] = s;
+ count++;
+ if (count >= size) {
+ size *= 2;
+ ret = realloc(ret, size * sizeof(char *));
}
- ret[count] = NULL;
- return ret;
+ }
+ ret[count] = NULL;
+ return ret;
}
char **getallvals () {
- return fgetallvals(stdin);
+ return fgetallvals(stdin);
}
param *getparam (void) {
- param *ret = malloc(sizeof(param));
-
- ret->name = NULL;
- ret->value = NULL;
-
- if ((ret->name = getkey()) == NULL ||
+ param *ret = malloc(sizeof(param));
+
+ ret->name = NULL;
+ ret->value = NULL;
+
+ if ((ret->name = getkey()) == NULL ||
(ret->value = getvalue()) == NULL) {
- freeparam(ret);
- return NULL;
- }
+ freeparam(ret);
+ return NULL;
+ }
- return ret;
+ return ret;
}
+/* Read all parameters, return NULL terminated array */
+param **getparams( void ) { /* {{{ */
+ /* Holds the parameters passed to this method. */
+ param **params;
+
+ param *p;
+ int numparams=4;
+ int curparam=0;
+
+ params = malloc(sizeof(param *) * numparams + 1 );
+ while ((p = getparam()))
+ {
+ //fprintf( stderr, "param: %s, %s.\n", p->name, p->value );
+ params[curparam++]=p;
+ if (curparam >= numparams)
+ {
+ numparams = numparams * 2;
+ params=realloc(params, sizeof(param *) * (numparams + 1));
+ }
+ }
+ params[curparam]=NULL;
+
+ return params;
+} /* }}} */
+
+/* Look up a parameter from an array by name. */
+char *findparam (const char *key, param **params) { /* {{{ */
+ /* TODO: optimize. hash? tsearch? */
+ int i;
+ for (i=0; params[i] != NULL; i++)
+ {
+ if (strcmp(key, params[i]->name) == 0)
+ {
+ return params[i]->value;
+ }
+ }
+ return NULL;
+} /* }}} */
+
int truefield (object *obj, const char *field) {
- char *file, *value;
-
- file = fieldfile(obj, field);
- if (! file)
- return 0;
+ char *file, *value;
- value = getfield(file);
- if (! value)
- return 0;
- if (! strlen(value))
- return 0;
- if (strcmp(value, "0") == 0)
- return 0;
- else
- return 1;
+ file = fieldfile(obj, field);
+ if (! file)
+ return 0;
+
+ value = getfield(file);
+ if (! value)
+ return 0;
+ if (! strlen(value))
+ return 0;
+ if (strcmp(value, "0") == 0)
+ return 0;
+ else
+ return 1;
}
char *getfield (const char *field) {
- char *ret;
- FILE *f = fopen(field, "r");
- if (f == NULL)
- return NULL;
- ret = mooix_getline(f, 0);
- fclose(f);
- return ret;
+ char *ret;
+ FILE *f = fopen(field, "r");
+ if (f == NULL)
+ return NULL;
+ ret = mooix_getline(f, 0);
+ fclose(f);
+ return ret;
}
int setfield (const char *field, const char *value) {
- FILE *f = fopen(field, "w");
- if (f == NULL)
- return 0;
- fprintf(f, "%s", value);
- fclose(f);
- return 1;
+ FILE *f = fopen(field, "w");
+ if (f == NULL)
+ return 0;
+ fprintf(f, "%s", value);
+ fclose(f);
+ return 1;
}
char *fieldfile (object *obj, const char *field) {
- int size, ods, fs, len;
- char *ret;
- char *p;
- struct stat buf;
- int depth = 0;
+ int size, ods, fs, len;
+ char *ret;
+ char *p;
+ struct stat buf;
+ int depth = 0;
- /* set up ret to hold obj->dir/field */
- ods = strlen(obj->dir);
- fs = strlen(field);
- len = ods + 1;
- size = len + fs + 128;
- ret=malloc(size * sizeof(char));
- ret[0]='\0';
- strcat(ret, obj->dir);
- strcat(ret, "/");
- p = ret + ods + 1;
-
- for (;;) {
- /* Add field to end and see if anything turns up. */
- len += fs;
- if (len >= size) {
- size *= 2;
- ret=realloc(ret, size * sizeof(char));
- /* ret might move, and thus so must p */
- p = ret + len - fs;
- }
- strcat(ret, field);
- if (stat(ret, &buf) == 0) {
- return ret;
- }
-
- /* jump back to end of directory */
- len -= fs;
- p[0]='\0';
+ /* set up ret to hold obj->dir/field */
+ ods = strlen(obj->dir);
+ fs = strlen(field);
+ len = ods + 1;
+ size = len + fs + 128;
+ ret=malloc(size * sizeof(char));
+ ret[0]='\0';
+ strcat(ret, obj->dir);
+ strcat(ret, "/");
+ p = ret + ods + 1;
- /* Add parent/ to end; make sure there is a parent */
- len += 7;
- if (len >= size) {
- size *= 2;
- ret=realloc(ret, size * sizeof(char));
- p = ret + len - 7;
- }
- strcat(ret, "parent/");
- p += 7; /* points to end of parent/ */
- if (stat(ret, &buf) != 0) {
- free(ret);
- return NULL; /* no more parents */
- }
+ for (;;) {
+ /* Add field to end and see if anything turns up. */
+ len += fs;
+ if (len >= size) {
+ size *= 2;
+ ret=realloc(ret, size * sizeof(char));
+ /* ret might move, and thus so must p */
+ p = ret + len - fs;
+ }
+ strcat(ret, field);
+ if (stat(ret, &buf) == 0) {
+ return ret;
+ }
- /* Just in case.. */
- depth++;
- if (depth > 200) {
- fprintf(stderr, "possible recursive parent loop: %s\n", ret);
- exit(1);
- }
+ /* jump back to end of directory */
+ len -= fs;
+ p[0]='\0';
+
+ /* Add parent/ to end; make sure there is a parent */
+ len += 7;
+ if (len >= size) {
+ size *= 2;
+ ret=realloc(ret, size * sizeof(char));
+ p = ret + len - 7;
}
+ strcat(ret, "parent/");
+ p += 7; /* points to end of parent/ */
+ if (stat(ret, &buf) != 0) {
+ free(ret);
+ return NULL; /* no more parents */
+ }
+
+ /* Just in case.. */
+ depth++;
+ if (depth > 200) {
+ fprintf(stderr, "possible recursive parent loop: %s\n", ret);
+ exit(1);
+ }
+ }
}
object *derefobj (const char *s) {
- object *ret;
+ object *ret;
- if (! s || strncmp(s, "mooix:", 6) != 0)
- return NULL;
-
- ret = malloc(sizeof(object));
- ret->dev = 0;
- ret->dir = strdup(s + 6);
+ if (! s || strncmp(s, "mooix:", 6) != 0)
+ return NULL;
- return ret;
+ ret = malloc(sizeof(object));
+ ret->dev = 0;
+ ret->dir = strdup(s + 6);
+
+ /* Clean newline from the dir */
+ ret->dir[ strcspn( ret->dir, "\n" ) ] = '\0';
+
+ return ret;
}
object *getobj (char *s) {
- object *ret = malloc(sizeof(object));
- ret->dev = 0;
- ret->dir = s;
- return ret;
+ object *ret = malloc(sizeof(object));
+ ret->dev = 0;
+ ret->dir = s;
+ return ret;
}
void freeobj (object *obj) {
- free(obj->dir);
- free(obj);
+ free(obj->dir);
+ free(obj);
}
/* This is very similar to _runmethod in the Mooix::Thing perl module.. */
FILE **runmethod_raw (object *obj, const char *method) {
- static FILE *ret[2];
- int pipe1[2], pipe2[2];
- int parent_rdr, child_wtr;
- int child_rdr, parent_wtr;
- pid_t pid;
+ static FILE *ret[2];
+ int pipe1[2], pipe2[2];
+ int parent_rdr, child_wtr;
+ int child_rdr, parent_wtr;
+ pid_t pid;
- /* Parent and child communication pipes. */
- pipe(pipe1);
- parent_rdr=pipe1[0];
- child_wtr=pipe1[1];
- pipe(pipe2);
- child_rdr=pipe2[0];
- parent_wtr=pipe2[1];
+ /* Parent and child communication pipes. */
+ pipe(pipe1);
+ parent_rdr=pipe1[0];
+ child_wtr=pipe1[1];
+ pipe(pipe2);
+ child_rdr=pipe2[0];
+ parent_wtr=pipe2[1];
- pid = fork();
- if (pid == -1) {
- close(parent_rdr);
- close(parent_wtr);
- close(child_rdr);
- close(child_wtr);
- return NULL;
- }
- else if (pid != 0) {
- ret[0]=fdopen(child_wtr, "w");
- ret[1]=fdopen(child_rdr, "r");
-
- /* Ignore sigpipes, which can easily occur if the child is
- * very quick to run and does not read its input. */
- signal(SIGPIPE, SIG_IGN);
+ pid = fork();
+ if (pid == -1) {
+ close(parent_rdr);
+ close(parent_wtr);
+ close(child_rdr);
+ close(child_wtr);
+ return NULL;
+ }
+ else if (pid != 0) {
+ ret[0]=fdopen(child_wtr, "w");
+ ret[1]=fdopen(child_rdr, "r");
- close(parent_rdr);
- close(parent_wtr);
+ /* Ignore sigpipes, which can easily occur if the child is
+ * very quick to run and does not read its input. */
+ signal(SIGPIPE, SIG_IGN);
- return ret;
+ close(parent_rdr);
+ close(parent_wtr);
+
+ return ret;
+ }
+ else {
+ char *qualmethod;
+
+ close(child_rdr);
+ close(child_wtr);
+
+ close(0);
+ dup2(parent_rdr, 0);
+ close(parent_rdr);
+ close(1);
+ dup2(parent_wtr, 1);
+ close(parent_wtr);
+
+ if (chdir(obj->dir) != 0)
+ exit(1);
+
+ qualmethod=fieldfile(getobj("."), method);
+ if (! qualmethod) {
+ exit(1);
}
+
+ if (getenv("THIS")) { /* in the moo */
+ execlp(qualmethod, qualmethod, NULL);
+ }
else {
- char *qualmethod;
-
- close(child_rdr);
- close(child_wtr);
+ execlp("runmeth", "runmeth", qualmethod, NULL);
+ }
+ fprintf(stderr, "failed to exec %s %s\n", obj->dir, qualmethod);
+ exit(1);
+ }
+}
- close(0);
- dup2(parent_rdr, 0);
- close(parent_rdr);
- close(1);
- dup2(parent_wtr, 1);
- close(parent_wtr);
+FILE *runmethod_param( object *obj, const char *method, param **params ) {
+ FILE *wtr, *rdr, **fds;
- if (chdir(obj->dir) != 0)
- exit(1);
+ fds = runmethod_raw(obj, method);
+ if (fds == NULL)
+ return NULL;
+ wtr = fds[0];
+ rdr = fds[1];
- qualmethod=fieldfile(getobj("."), method);
- if (! qualmethod) {
- exit(1);
- }
-
- if (getenv("THIS")) { /* in the moo */
- execlp(qualmethod, qualmethod, NULL);
- }
- else {
- execlp("runmeth", "runmeth", qualmethod, NULL);
- }
- fprintf(stderr, "failed to exec %s %s\n", obj->dir, qualmethod);
- exit(1);
+ /* Pass params to child. */
+ if (params) {
+ int i;
+ for (i = 0; params[i] != NULL; i++)
+ {
+ fprintf(wtr, "%s\n", params[i]->name);
+ //fprintf(stderr, "%s\n", params[i]->name);
+ fprintf(wtr, "%s\n", params[i]->value);
+ //fprintf(stderr, "%s\n", params[i]->value);
}
-}
+ }
+ fclose(wtr); /* let child know we're done so it can run */
+ return rdr;
+}
FILE *runmethod (object *obj, const char *method, char **params) {
- FILE *wtr, *rdr, **fds;
-
- fds = runmethod_raw(obj, method);
- if (fds == NULL)
- return NULL;
- wtr = fds[0];
- rdr = fds[1];
-
- /* Pass params to child. */
- if (params) {
- int i;
- for (i = 0; params[i] != NULL; i++)
- fprintf(wtr, "%s\n", params[i]);
+ FILE *wtr, *rdr, **fds;
+
+ fds = runmethod_raw(obj, method);
+ if (fds == NULL)
+ return NULL;
+ wtr = fds[0];
+ rdr = fds[1];
+
+ /* Pass params to child. */
+ if (params) {
+ int i;
+ for (i = 0; params[i] != NULL; i++)
+ {
+ fprintf(wtr, "%s\n", params[i]);
+ //fprintf(stderr, "%s\n", params[i]);
}
- fclose(wtr); /* let child know we're done so it can run */
-
- return rdr;
+ }
+ fclose(wtr); /* let child know we're done so it can run */
+
+ return rdr;
}
int statobj (object *obj) {
- struct stat buf;
- if (stat(obj->dir, &buf) != 0)
- return 0;
- obj->dev = buf.st_dev;
- obj->ino = buf.st_ino;
- return 1;
+ struct stat buf;
+ if (stat(obj->dir, &buf) != 0)
+ return 0;
+ obj->dev = buf.st_dev;
+ obj->ino = buf.st_ino;
+ return 1;
}
int objcmp (object *a, object *b) {
- /* The stat info is cached between calls. */
- if (! a->dev) {
- if (! statobj(a))
- return -1;
+ /* The stat info is cached between calls. */
+ if (! a->dev) {
+ if (! statobj(a))
+ return -1;
+ }
+ if (! b->dev) {
+ if (! statobj(b))
+ return -1;
+ }
+
+ /* Return as does strcmp. */
+ if (a->dev != b->dev)
+ return (a->dev > b->dev) - (a->dev < b->dev);
+ else
+ return (a->ino > b->ino) - (a->ino < b->ino);
+}
+
+/* Generate a prettified name for an object, from the POV of the
+ * recipient. other_pov means that the name is to be treated as
+ * though a third-person perspective pertained.
+ */
+
+char *internal_prettyname( object *obj, object *recipient, int other_pov ) { /* {{{ */
+ char *name, *article, *file;
+ struct stat buf;
+
+ if( objcmp(obj, recipient) == 0 && ! other_pov )
+ {
+ char *lang_field_file;
+ object *lang_obj;
+ char *pronoun;
+
+ /* At this point, we need at least the final seperator. */
+
+ lang_field_file = fieldfile( recipient, "language" );
+
+ if( lang_field_file == NULL ) {
+ /* No language; can't pick a seperator. Error out.
+ * */
+ fprintf( stderr, "Recipient %s has no language in prettyname.\n", recipient->dir );
+ pronoun = malloc( 1024 * sizeof( char ) );
+ sprintf( pronoun, "ERROR: Recipient %s has no language in prettyname.\n", recipient->dir );
+ return pronoun;
}
- if (! b->dev) {
- if (! statobj(b))
- return -1;
+
+ lang_obj = getobj( lang_field_file );
+
+ pronoun = getfield( fieldfile( lang_obj, "second_person_singular_pronoun" ) );
+
+ return pronoun;
+ }
+
+ file = fieldfile(obj, "name");
+ if (! file)
+ return "";
+ /* The name might be a method to be called with no parameters.
+ * Rarely, but worth the stat for consistency. */
+ if (stat(file, &buf) != 0)
+ return "";
+ if (((buf.st_mode & S_IXUSR) == S_IXUSR) ||
+ ((buf.st_mode & S_IXGRP) == S_IXGRP) ||
+ ((buf.st_mode & S_IXOTH) == S_IXOTH)) {
+ /* Only allow running of methods that are marked as safe. */
+ if (! truefield(obj, ".name-safe")) {
+ return "";
}
+ else {
+ FILE *f = runmethod(obj, "name", NULL);
+ if (! f)
+ return "";
+ name = fgetvalue(f);
+ fclose(f);
+ }
+ }
+ else {
+ name = getfield(file);
+ }
- /* Return as does strcmp. */
- if (a->dev != b->dev)
- return (a->dev > b->dev) - (a->dev < b->dev);
- else
- return (a->ino > b->ino) - (a->ino < b->ino);
+ /* Hmm, article could be a method too, but it seems a little silly
+ * to support that. */
+ file = fieldfile(obj, "article");
+
+ if (! file)
+ {
+ return "";
+ }
+
+ article = dexml( getfield(file), recipient, "" );
+
+ if (! article || ! strlen(article))
+ {
+ char *ret = malloc(strlen(article) + 1 + strlen(name) + 1 + 13);
+ sprintf(ret, "%s", name);
+ return dexml( ret, recipient, "" );
+ } else {
+ char *ret = malloc(strlen(article) + 1 + strlen(name) + 1 + 13);
+ sprintf(ret, "%s %s", article, name);
+ return dexml( ret, recipient, "" );
+ }
+} /* }}} */
+
+/* Wrapper for internal_prettyname with other_pov off */
+char *prettyname( object *obj, object *recipient )
+{
+ return internal_prettyname( obj, recipient, 0 );
}
+
+/* Wrapper for internal_prettyname with other_pov on */
+char *other_prettyname( object *obj, object *recipient )
+{
+ return internal_prettyname( obj, recipient, 1 );
+}
+
+
+/*
+ * Everything from here down
+ *
+ * is support functions for dexml, which is rather complicated. It
+ * strips XML tags out based on the avatar's language and other
+ * factors.
+ *
+ */
+
+//FILE *log_file;
+int skip=0;
+int skip_depth=0;
+int trailing_space=0;
+char *parse_result;
+char *parse_lang_code;
+
+/* Marks that the next initial alphabetic character should be made
+ * upper case
+ */
+int uc_next=0;
+/* Marks that this is a language in which sentence-initial
+ * characters are made upper case.
+ */
+int uc_initial_lang=0;
+
+/* Pull a list of language codes used in the current text. */
+char **find_text_lang_codes( char *text, int *num_codes )
+{
+ int status;
+ /* Only two possible matches: the main match and the one
+ * sub-expression. We only care about the latter.
+ * */
+ regmatch_t lang_matches[2];
+ regex_t lang_re;
+ int offset=0;
+
+ /* Truly it would be a happy day when a moo has stuff translated
+ * into 129 languages...
+ */
+ char **lang_codes;
+
+ /* 128 32 byte lang codes */
+ lang_codes = malloc( 128 * sizeof( char * ) );
+ lang_codes[0] = malloc( 32 * sizeof( char ) );
+ lang_codes[0][0] = '\0';
+
+ if( regcomp( &lang_re, "[<]lang code=['\"]([^'\"<>]*)['\"][>]", REG_EXTENDED ) != 0 )
+ {
+ return( NULL ); /* report error */
+ }
+
+ status = regexec( &lang_re, text, (size_t) 2, lang_matches, 0);
+
+ /* If no matches found */
+ if (status != 0) {
+ return NULL;
+ }
+
+ //printf( "Test: %d, %d.\n", lang_matches[0].rm_so, status );
+
+ while( regexec( &lang_re, text+offset, 2, lang_matches, 0) == 0 && lang_matches[1].rm_so >= 0 ) /* Found a match */
+ {
+ /* See if this one is new */
+ int j = 0;
+ int found = 0;
+
+ //printf( "Test1.5: %d, %d, %d.\n", lang_matches[1].rm_so, j, *num_codes );
+
+ for( j = 0; j < *num_codes; j++ )
+ {
+ //printf( "Test1.75: %s.\n", lang_codes[j] );
+ /* If this one does not match an old one */
+ if( strncmp( lang_codes[j],
+ text + offset + lang_matches[1].rm_so,
+ lang_matches[1].rm_eo - lang_matches[1].rm_so
+ ) == 0 )
+ {
+ found = 1;
+ }
+ }
+ //printf( "Test2: %d, %d, %d, %s.\n", j, *num_codes, found, lang_codes[*num_codes] );
+
+ /* If we didn't find a match */
+ if( found == 0 )
+ {
+ strncpy( lang_codes[*num_codes],
+ text + offset + lang_matches[1].rm_so,
+ lang_matches[1].rm_eo - lang_matches[1].rm_so
+ );
+
+ lang_codes[*num_codes][lang_matches[1].rm_eo - lang_matches[1].rm_so] = '\0';
+
+ //printf( "Test2.1: %d, %d, %d, %s.\n", j, *num_codes, found, lang_codes[*num_codes] );
+ *num_codes = *num_codes + 1;
+
+ lang_codes[*num_codes] = malloc( 32 * sizeof( char ) );
+ lang_codes[*num_codes][0] = '\0';
+ //printf( "Test2.2: %d, %d, %d, %s.\n", j, *num_codes, found, lang_codes[*num_codes] );
+ }
+
+ offset += lang_matches[1].rm_eo; /* Update the offset */
+ }
+
+ regfree( &lang_re );
+
+ return lang_codes;
+}
+
+/* Looks at the language codes present in the text, and compares
+ * them with the language codes the user prefers, in order,
+ * attempting to find the best match.
+ *
+ * If no language codes are present in the text, sets
+ * parse_lang_code to the user's first language preference.
+ *
+ * If the user has no language preferences, sets parse_lang_code to
+ * the first language code found in the text, if any.
+ *
+ * Returns 0 if no language codes were found in the text (so we can
+ * avoid further processing), 1 otherwise.
+ * */
+void find_best_lang_code( char *text, object *dexml_recipient )
+{
+ char **lang_codes;
+ char *lang_field_file;
+ char *code_field_file;
+ FILE *code_field_fp;
+ char language[256];
+ char best_language[256];
+ int num_codes=0;
+ object *lang_obj;
+
+ parse_lang_code = malloc( 256 * sizeof( char ) );
+ parse_lang_code[0] = '\0';
+
+ lang_codes = find_text_lang_codes( text, &num_codes );
+
+ //printf( "Test3: %s.\n", getenv( "THIS" ) );
+
+ lang_field_file = fieldfile( dexml_recipient, "language" );
+
+ if( lang_field_file == NULL ) {
+ fprintf( stderr, "No language field in avatar %s in dexml.\n", dexml_recipient->dir );
+ /* No language preferences */
+ strcpy( parse_lang_code, lang_codes[0] );
+ return;
+ }
+
+ lang_obj = getobj( lang_field_file );
+
+ code_field_file = fieldfile( lang_obj, "code" );
+
+ if( code_field_file == NULL ) {
+ /* No language preferences */
+ strcpy( parse_lang_code, lang_codes[0] );
+ return;
+ }
+
+ /* What we really want is the language's code file */
+ //printf( "Test4: %s.\n",code_field_file );
+
+ code_field_fp = fopen(code_field_file, "r");
+
+ if( code_field_fp == NULL ) {
+ /* No language preferences */
+ strcpy( parse_lang_code, lang_codes[0] );
+ return;
+ }
+
+ //printf( "Test5.\n" );
+
+ /* Check for a match between the language's code and the ones we
+ * pulled from the text in question. We allow it to be
+ * mult-line in case one wants aliases or to match extended
+ * languages like en-uk
+ */
+ while( fgets(language, 256, code_field_fp) != NULL )
+ {
+
+ /* This will only run on the first run of the while, as we
+ * return, so it will only act on the first line of the
+ * languages field. */
+ if( num_codes == 0 )
+ {
+ /* Call it the user's most preferred language; this will be
+ * used for initial upper case decision making.
+ * */
+ strcpy( parse_lang_code, language );
+ //printf("no lang codes found; parse langcode: %s.\n", parse_lang_code );
+ return;
+ }
+
+ /* Kill the newline. */
+ language[ strspn( language, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-" ) ] = '\0';
+ //printf( "Test6: %s.\n", language );
+ int j;
+
+ for( j = 0; j < num_codes; j++ )
+ {
+ /* Look for a match between the codes in the text and
+ * the languages the avatar will accept, in order of
+ * acceptance.
+ * */
+ if( strcmp( language, lang_codes[j] ) == 0 )
+ {
+ strcpy( best_language, language );
+ /* sprintf( parse_lang_code, "joy: We found %d lang codes; %s, %s; %s.\n", num_codes, lang_codes[0], lang_codes[1], best_language );*/
+ //printf( "joy: We found %d lang codes; %s, %s; %s.\n", num_codes, lang_codes[0], lang_codes[1], best_language );
+
+ strcpy( parse_lang_code, best_language );
+ return;
+ }
+ }
+
+ }
+
+ /* Else, just return whatever language we saw first in the text.
+ sprintf( parse_lang_code, "no joy; We found %d lang codes; %s, %s; %s.\n", num_codes, lang_codes[0], lang_codes[1], lang_codes[0] );
+ * */
+ //printf( "no joy; We found %d lang codes; %s, %s; %s.\n", num_codes, lang_codes[0], lang_codes[1], lang_codes[0] );
+
+ strcpy( parse_lang_code, lang_codes[0] );
+
+ //printf("langcode: %s.\n", parse_lang_code );
+
+ return;
+}
+
+
+void replaceWordInText(const char* find, const char* replace, char* text)
+{
+ /* Cook until done */
+ while( 1 )
+ {
+ char *beginning=strstr(text, find);
+
+ if( beginning )
+ {
+ memmove(beginning+strlen(replace), beginning+strlen(find), 1+strlen(beginning+strlen(find)));
+ strncpy(beginning, replace, strlen(replace));
+ } else {
+ break;
+ }
+ }
+}
+
+static void XMLCALL xml_start(void *data, const char *el, const char **attr)
+{
+ int i;
+
+ //printf("start tag: %s\n", el);
+
+ /* If we found a lang tag, process it looking to see if the code
+ * matches */
+ if( strcmp( el, "lang" ) == 0 )
+ {
+ //printf( "lang start tag found.\n" );
+ /* Increase our depth within the skip block, if this is a
+ * valid lang tag */
+ if( skip == 1 )
+ {
+ //printf( "lang start tag found in skip block.\n" );
+ /* Look for a code attribute; otherwise this is an
+ * invalid lang tag, so we ignore it.
+ */
+ for (i = 0; attr[i]; i += 2)
+ {
+ //printf("start tag attr: %s='%s', %s\n", attr[i], attr[i + 1], parse_lang_code);
+ if( strcmp( attr[i], "code" ) == 0 )
+ {
+ skip_depth++;
+ //printf( "Increasing skip depth to %d.\n", skip_depth );
+ }
+ }
+ //printf( "done with lang start tag found in skip block.\n" );
+ } else {
+ /* Not skipping, find out if we should be. */
+ for (i = 0; attr[i]; i += 2)
+ {
+ //printf("start tag attr: %s='%s', %s\n", attr[i], attr[i + 1], parse_lang_code);
+ if( strcmp( attr[i], "code" ) == 0 )
+ {
+ if( strcmp( attr[i + 1], parse_lang_code ) == 0 )
+ {
+ //printf( "best lang found.\n" );
+ } else {
+ //printf( "non-best lang found.\n" );
+ skip = 1;
+ skip_depth = 0;
+ }
+ }
+ }
+ }
+ } else if( strcmp( el, "document" ) == 0 ) {
+ /* If tag is the artificially added tag, drop it
+ */
+ ;
+ } else if( skip == 1 ) {
+ /* Drop all skipped tags, unless otherwise handled above */
+ ;
+ } else if( strcmp( el, "mspace" ) == 0 ) {
+ /* is used where we want a space, but only if
+ * there isn't already one just in front. This is for
+ * articles; the article in one language might be blank, so
+ * we can't just put in spaces every time.
+ */
+ if( ! trailing_space )
+ {
+ strcat( parse_result, " " );
+ }
+ } else if( strcmp( el, "initial" ) == 0 ) {
+ /* The tag is added by msg.c to point out the
+ * place where the next non-tagged character should be
+ * counted as in initial character in a string in languages
+ * that have that sort of thing.
+ */
+ //printf( "Initial tag found.\n" );
+ if( uc_initial_lang )
+ {
+ //printf( "UC next set.\n" );
+ uc_next = 1;
+ }
+ } else {
+ /* If the tag is not a tag we want to process, preserve it */
+
+ strcat( parse_result, "<" );
+ strcat( parse_result, el );
+
+ for (i = 0; attr[i]; i += 2)
+ {
+ strcat( parse_result, " " );
+ strcat( parse_result, attr[i] );
+ strcat( parse_result, "=" );
+ strcat( parse_result, attr[i + 1] );
+ }
+
+ strcat( parse_result, ">" );
+ //printf( "Updated p_r: %s.\n", parse_result );
+ }
+
+ //printf("\n");
+}
+
+static void XMLCALL xml_end(void *data, const char *el)
+{
+ //printf("end tag: %s, %d, %d\n", el, skip, skip_depth);
+
+ if( strcmp( el, "lang" ) == 0 )
+ {
+ /* Decrease our depth within the skip block */
+ if( skip == 1 )
+ {
+ skip_depth--;
+ //printf( "Decreasing skip depth to %d.\n", skip_depth );
+ }
+
+ /* If this is the end of the outermost skip block, stop
+ * skipping. */
+ if( skip_depth < 0 )
+ {
+ skip = 0;
+ skip_depth = 0;
+ //printf( "Turning skip off.\n");
+ }
+ } else if( strcmp( el, "document" ) == 0 ) {
+ /* If tag is the artificially added tag, drop it
+ */
+ ;
+ } else if( skip == 1 ) {
+ /* Drop all skipped tags, unless otherwise handled above */
+ ;
+ } else if( strcmp( el, "mspace" ) == 0 ) {
+ /* We only use the end tag. Discard. */
+ ;
+ } else if( strcmp( el, "initial" ) == 0 ) {
+ /* We only use the end tag. Discard. */
+ ;
+ } else {
+ /* If the tag is not a tag we want to process, preserve it */
+ strcat( parse_result, "" );
+ }
+
+}
+
+/* Upper cases the first alphabetic character in the string. */
+void upper_case_next( char *scratch )
+{
+ /* Walk the string for the first alphabetic
+ * character and uppercase it.
+ * */
+ int i;
+
+ for( i = 0; i < strlen( scratch ); i++ )
+ {
+ if( isalpha( scratch[i] ) )
+ {
+ scratch[i] = toupper( scratch[i] );
+ /* Reset the flag to upper-case the next character */
+ uc_next = 0;
+ break;
+ }
+ }
+}
+
+static void XMLCALL char_data_handler(void *data, const char *el, int len)
+{
+ char *scratch;
+
+ /* Give extra space because of the < to < expansion. */
+ scratch = malloc( ( ( len * 2 ) + 1 ) * sizeof( char ) );
+ scratch[0] = '\0';
+
+ if( skip == 0 )
+ {
+ //printf("YES char data: %d, %.*s\n", len, len, el);
+
+ strncat( scratch, el, len );
+
+ /* If we need to upper case the next letter, go and do it.
+ */
+ if( uc_next )
+ {
+ upper_case_next( scratch );
+ }
+
+ /* Don't want to break privledged tag protection. */
+ replaceWordInText( "<", "<", scratch );
+ replaceWordInText( ">", ">", scratch );
+
+ strcat( parse_result, scratch );
+
+ /* Look for a space at the end of the text */
+ if( isblank( el[ len - 1] ) )
+ {
+ //printf( "Setting trailing space based on: %c from %.*s.\n", el[ len - 1], len, el );
+ trailing_space = 1;
+ } else {
+ //printf( "Unsetting trailing space based on: %c from %.*s.\n", el[ len - 1], len, el );
+ trailing_space = 0;
+ }
+
+ //printf( "Updated p_r: %s.\n", parse_result );
+ } else {
+ //printf("NO char data: %d, %.*s\n", len, len, el);
+ }
+
+ free( scratch );
+}
+
+/* Attempt to parse text, putting the raw text into parse_result if
+ * an error occurs.
+ */
+void my_parse( char *text, int length )
+{
+ char *original_parse_result_end;
+ char *fixed_text;
+
+ XML_Parser p = XML_ParserCreate(NULL);
+
+ if (! p) {
+ //fprintf(stderr, "Couldn't allocate memory for parser\n");
+ exit(-1);
+ }
+
+ XML_SetElementHandler(p, xml_start, xml_end);
+ XML_SetCharacterDataHandler(p, char_data_handler);
+
+ /* Mark the current end of parse_result in case we need
+ * to blow away what we've done because of an XML error.
+ */
+ original_parse_result_end = &parse_result[strlen(parse_result)];
+
+ fixed_text = malloc( ( ( length * sizeof( char ) ) + 128 ) * 2 );
+ fixed_text[0] = '\0';
+
+ sprintf( fixed_text, "%.*s", length, text );
+
+ //fprintf( stderr, "my_parse langcode: %s.\n", parse_lang_code );
+ //fprintf( stderr, "my_parse fixed text: %s.\n", fixed_text );
+
+ if( XML_Parse(p, fixed_text, strlen( fixed_text ), 1) == XML_STATUS_ERROR )
+ {
+ /* Copy the de-tagged text to parse_result */
+ original_parse_result_end[0] = '\0';
+ strncat( parse_result, text, length );
+
+ /* Put the terminator back in. */
+ text[length] = '\0';
+ //printf( "parse result after error: %s.\n", parse_result );
+ }
+
+ /* Reset all parsing flags. */
+ skip=0;
+ skip_depth=0;
+}
+
+/* Remove xml tags from the text. is supported; marked up
+ * in bold alter down the stream, all else are ignored. Also handle
+ * entities. In the vast majority of cases, uses dexml_recipient,
+ * which is an avatar, to determine the preferred language, but in
+ * some cases (read: parsers), uses the language argument instead.
+ */
+char *dexml( char *text, object *dexml_recipient, char *language )
+{
+ int len;
+
+ //fprintf( stderr, "In dexml.\n", text );
+
+ if( text )
+ {
+ len = strlen(text);
+ } else {
+ return "";
+ }
+
+ if (len == 0)
+ {
+ return "";
+ }
+
+ //fprintf( stderr, "dexml pre: %s.\n", text );
+
+ /* Allocate some extra space (double, in fact, plus some extra
+ * for the xml header crap) for XML processing to increase the
+ * size of the string
+ */
+ parse_result = malloc( ( ( len * sizeof( char ) ) + 128 ) * 2 );
+
+ parse_result[0] = '\0';
+
+ /* Only check the avatar's language if we weren't passed an
+ * explicit language code.
+ */
+ if( dexml_recipient && ( ! language || strlen( language ) == 0 ) )
+ {
+ //fprintf( stderr, "dexml recip: %s.\n", dexml_recipient->dir );
+ find_best_lang_code( text, dexml_recipient );
+ } else {
+ if( language )
+ {
+ //fprintf( stderr, "dexml lang: %s.\n", language );
+ parse_lang_code = language;
+ } else {
+ return text;
+ }
+ }
+
+ //fprintf( stderr, "still in dexml.\n" );
+
+ /* Make sure we have a terminating null before any wierd
+ * characters, like newline. Even in C there has to be a
+ * better way to do this. */
+ parse_lang_code[ strspn( parse_lang_code, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-" ) ] = '\0';
+
+ //fprintf( stderr, "dexml parse_lang_code: %s.\n", parse_lang_code );
+
+ /* Don't run XML processing if we've got no lang codes at all.
+ */
+ if( parse_lang_code != NULL && parse_lang_code[0] != '\0' )
+ {
+ char *lang_field_file;
+ char *uc_initial_lang_file;
+ FILE *uc_initial_lang_fp;
+
+ /* Set uc_initial to zero if we were passed a lang code;
+ * should only be used by short text blocks passed by
+ * parsers.
+ */
+ if( language && strlen( language ) > 0 )
+ {
+ uc_initial_lang = 0;
+ } else {
+ /* Only find out about upper case initial status if we
+ * weren't passed a language code.
+ */
+
+ /* Find the list of languages that have their initial
+ * letter upper-cased (i.e., most romance languages) */
+ lang_field_file = fieldfile( dexml_recipient, "language" );
+
+ if( lang_field_file != NULL )
+ {
+ object *lang_obj;
+ lang_obj = getobj( lang_field_file );
+
+ uc_initial_lang_file = fieldfile( lang_obj, "upper_case_initial" );
+
+ if( uc_initial_lang_file != NULL )
+ {
+ //printf( "uc_initial_lang_file: %s.\n", uc_initial_lang_file );
+ uc_initial_lang_fp = fopen(uc_initial_lang_file, "r");
+
+ if( uc_initial_lang_fp != NULL )
+ {
+ char flag_string[8];
+
+ if( fgets(flag_string, 8, uc_initial_lang_fp) != NULL )
+ {
+ int flag;
+
+ /* Grab the field as an integer; it's either 0 or 1 */
+ flag = strtol(flag_string, (char **)NULL, 10);
+ if( flag )
+ {
+ uc_initial_lang = 1;
+ }
+ }
+ }
+ }
+ }
+ }
+
+ //fprintf( stderr, "Language UC initial is %d.\n", uc_initial_lang );
+
+ my_parse( text, strlen(text) );
+
+ //fprintf( stderr, "dexml post: %s.\n", parse_result );
+ return parse_result;
+ } else {
+ return text;
+ }
+}
Index: bindings/c/Makefile
===================================================================
--- bindings/c/Makefile (revision 23)
+++ bindings/c/Makefile (working copy)
@@ -10,7 +10,7 @@
CFLAGS += -g -fPIC -DPIC -Wall
$(LIB): $(objs)
- $(CC) $(CFLAGS) -lc -shared -Wl,-soname -Wl,$(LIB).$(SONAME) $(objs) -o $(LIB).$(SONAME)
+ $(CC) $(CFLAGS) -lexpat -lc -shared -Wl,-soname -Wl,$(LIB).$(SONAME) $(objs) -o $(LIB).$(SONAME)
rm -f $(LIB)
$(LN_S) $(LIB).$(SONAME) $(LIB)
Index: INSTALL
===================================================================
--- INSTALL (revision 23)
+++ INSTALL (working copy)
@@ -58,6 +58,14 @@
/etc/ld.so.conf to list the directory the mooix libraries were
installed into, and run ldconfig.
+ To install to somewhere other than the location the code
+ will be running at (something like a chroot or VServer,
+ where mood might be in /usr/sbin/mood but you want to
+ install to /chroot/path/usr/sbin/moot) run make install as
+ follows:
+
+ make PREFIX=[wierd installation path] install
+
Initialization
==============
Index: mooix.conf
===================================================================
--- mooix.conf (revision 23)
+++ mooix.conf (working copy)
@@ -16,33 +16,33 @@
# running at a time in the moo, and more is better. Mood will only use
# users in this space as scratch users if they have no entries in the
# password file at the time it is started up.
-LOWUID=31000
-HIGHUID=32000
+LOWUID=3000
+HIGHUID=4000
# Base of the moo object tree. Please note that you can change this at
# build time, but it's fairly rooted to this location once installed.
-MOOROOT=$(localstatedir)/lib/mooix
+MOOROOT=/var/lib/mooix
# Distributed objects. This directory holds all the static mooix
# objects that are distributed with mooix.
-DISTOBJ=$(libdir)/mooix
+DISTOBJ=/usr/lib/mooix
# These are objects that have the same powers as the moo admin, but more
# limited purposes. Note that the order is significant; the first object
# listed should be the one most often used.
-MOOADMINOBJ=$(localstatedir)/lib/mooix/abstract/physics
-MOOADMINOBJ=$(localstatedir)/lib/mooix/system/heartbeat
+MOOADMINOBJ=/var/lib/mooix/abstract/physics
+MOOADMINOBJ=/var/lib/mooix/system/heartbeat
# This is the object that is the moo admin. It can modify any field of any
# other object.
-MOOADMINOBJ=$(localstatedir)/lib/mooix/system/admin
+MOOADMINOBJ=/var/lib/mooix/system/admin
# This string is prefixed to the user names of new users who register for
# moo accounts. It should be short, since there are only 8 characters
# available for the whole name on most systems.
-MOOUSERPREFIX=m-
+MOOUSERPREFIX=
# Newly registered users will get this type of avatar.
-PARENTAVATAR="$(localstatedir)/lib/mooix/abstract/avatar"
+PARENTAVATAR="/var/lib/mooix/abstract/avatar"
# This command is run at moo startup time.
STARTHOOK="cd $MOOROOT/system/init && runmeth startup"
@@ -55,7 +55,7 @@
# Some commands, like moologin, need a sanitized PATH, not the one from the
# environment. This sets that path.
-SAFEPATH=/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin:$(sbindir)
+SAFEPATH=/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin:/usr/sbin
# The following variables set hard resource limits for the mood daemon, and
# the mooix methods it executes.
@@ -89,10 +89,10 @@
# part of a single method. It is useful to prevent methods from fork bombing
# the moo. This does not influence the number of methods that may run at
# once. For that you can make the gap between HIGHUID and LOWUID be small.
-RLIMIT_NPROC=10
+RLIMIT_NPROC=128
#
# The maximum number of files that a process can open at a time.
-RLIMIT_NOFILE=100
+RLIMIT_NOFILE=1024
#
# The total amount of memory a process can get.
#RLIMIT_AS=
Index: MULTILINGUAL
===================================================================
--- MULTILINGUAL (revision 0)
+++ MULTILINGUAL (revision 0)
@@ -0,0 +1,21 @@
+mooix now has full support for multilingual MOOs, that is, MOOs in
+which different users are interacting with the MOO, and seeing the
+MOO presented in, different languages.
+
+For details of how to set this up for new languages can be found by
+doing "help multilingual" in the MOO itself.
+
+All of this work was done by Robin Powell, aka
+rlpowell@digitalkingdom.org; all comments, questions, and bug
+reports on the multilingual code should be directed to him.
+
+PLEASE NOTE: No work was done on UTF-8 or other high byte handling!
+
+The language I was using (Lojban, see http://www.lojban.org/) is
+expressible in ASCII, and I don't know enough C or enough about
+UTF-* to know how to make things work properly at the C level.
+
+I would be VERY HAPPY if someone else made mooix UTF-8 safe!
+
+-Robin Lee Powell, 2 Jan 2005
+
Index: obj/mixin/mcp/simpleedit/receive_set
===================================================================
--- obj/mixin/mcp/simpleedit/receive_set (revision 23)
+++ obj/mixin/mcp/simpleedit/receive_set (working copy)
@@ -15,5 +15,5 @@
}
return $this->avatar->edit_finish(session => $this, value => $content,
- id => $_{reference});
+ id => $_{reference}, avatar => $this->avatar );
}
Index: obj/mixin/parser/supply.msg
===================================================================
--- obj/mixin/parser/supply.msg (revision 0)
+++ obj/mixin/parser/supply.msg (revision 0)
@@ -0,0 +1 @@
+The parser believes that you need to supply the following parts of speech: $incompletes.
Index: obj/mixin/parser/pronouns
===================================================================
--- obj/mixin/parser/pronouns (revision 23)
+++ obj/mixin/parser/pronouns (working copy)
@@ -1,31 +0,0 @@
-it
-its
-me
-myself
-I
-my
-here
-you
-your
-her
-she
-he
-him
-his
-us
-our
-them
-their
-this
-these
-that
-those
-everything
-everythings
-everyone
-everyones
-anything
-anythings
-all
-any
-each
Index: obj/mixin/parser/wtf.msg
===================================================================
--- obj/mixin/parser/wtf.msg (revision 0)
+++ obj/mixin/parser/wtf.msg (revision 0)
@@ -0,0 +1 @@
+I have no idea what you said. I see no verb.
Index: obj/mixin/parser/grammar
===================================================================
--- obj/mixin/parser/grammar (revision 23)
+++ obj/mixin/parser/grammar (working copy)
@@ -1,302 +0,0 @@
-#!/usr/bin/perl (more or less)
-
-# This file contains the Parse::RecDescent grammar used by the parser to
-# deconstruct imperative sentences.
-#
-# The resulting parser builds and returns a parse tree.
-# The form of the tree is a list of hashes (sentences).
-# The sentance hashes can have keys named verb, direct_object,
-# indirect_object, do_preposition, io_preposition, and quote
-# (and a couple more weird ones).
-#
-# Thank god for HyperGrammar!
-#
-
-# Handle compound sentences, and multiple sentences too.
-input: sentence (sentence_separator sentence)(s?) sentence_punct(?)
- { $item[2] ? [ $item[1], @{$item[2]} ] : [ $item[1] ] }
-sentence_separator: /$/ | sentence_punct(?) coordinating_conjunction(s) | sentence_punct
-
-# All the sentence forms. The ordering is quite important. I've tried to
-# put the most commonly used forms first, so they'll be faster. Note that
-# the use of lookahead is important in getting those fast, commonly-used
-# forms to not match on subsets of longer sentences.
-#
-# Once each sentence is parsed, a call to main::recent_obj() is made,
-# passing in any recently referred to objects. This is generally used to
-# set up the 'it' and 'them' prepositions, or similar.
-
-# Talking is quick to match.
-sentence: verb quote ...sentence_separator
- { { verb => $item[1], quote => $item[2] } }
-# This form is used to invoke the name of an exit to use it.
-# (It can also be used to answer some questions.) It needs to come before
-# the verb direct_object form. Probably calling recent_obj here would just
-# be confusing.
-sentence: object ...sentence_separator
- { { direct_object => $item[1] } }
-# "sit down", "get up", etc. Has to come before the verb direct_object form.
-sentence: verb preposition ...sentence_separator
- { { verb => $item[1], preposition => $item[2] } }
-# Probably the most common sentence form.
-sentence: verb direct_object ...sentence_separator
- { &::recent_obj(@{$item[2]});
- { verb => $item[1], direct_object => $item[2] } }
-# This form is used to "pick up foo", etc.
-sentence: verb do_preposition direct_object ...sentence_separator
- { &::recent_obj(@{$item[3]});
- { verb => $item[1], do_preposition => $item[2],
- direct_object => $item[3] } }
-# This form is used in eg, "put it down" or "wind it up".
-sentence: verb direct_object do_preposition ...sentence_separator
- { &::recent_obj(@{$item[2]});
- { verb => $item[1], do_preposition => $item[3],
- direct_object => $item[2] } }
-# "put blah in foo", etc is quite common.
-sentence: verb do_preposition(?) direct_object io_preposition(?) indirect_object
- { &::recent_obj(@{$item[3]}); # which object? Dunno. :-/
- { verb => $item[1], do_preposition => $item[2][0],
- direct_object => $item[3], io_preposition => $item[4][0],
- indirect_object => $item[5] } }
-# Not exactly sentences per se, but support answers to recently asked
-# questions. That generally involves picking a choice from a list or
-# answers, either by name or number. Or it might involve referring to a
-# particular object, or be a prepositional phrase.
-sentence: article(?) answer(s) ...sentence_separator
- { { answer => $item{'answer(s)'} } }
-sentence: article(?) number ...sentence_separator
- { { number => $item{number} } }
-sentence: do_preposition object ...sentence_separator
- { { direct_object => $item{object},
- do_preposition => $item{do_preposition} } }
-# Simple commands are way up there too (but must come after the simple
-# question answer forms).
-sentence: verb ...sentence_separator
- { { verb => $item[1] } }
-
-# This is a gross special case for a few commands that take a field as
-# their last argument.
-fieldverb: /(show|showall|set|unset|edit|delete|usage|help|go|list)\b/i
-# A special terminator is needed to disambiguate from things like
-# "show ball then drop it", where "then" could be misinterpreted as a
-# field.
-# Must come before the verb quote direct_object form.
-sentence: fieldverb do_preposition(?) possessive_object field ...sentence_separator
- { &::recent_obj(@{$item[3]});
- { verb => $item[1], do_preposition => $item[2][0],
- direct_object => $item[3], field => $item[4] } }
-sentence: fieldverb do_preposition(?) possessive_object number field ...sentence_separator
- { &::recent_obj(@{$item[3]});
- { verb => $item[1], do_preposition => $item[2][0],
- direct_object => $item[3], number => $item[4], field => $item[5] } }
-# Used for the help command.
-sentence: fieldverb do_preposition(?) field ...sentence_separator
- { { verb => $item[1], do_preposition => $item[2][0], field => $item[3] } }
-
-# "say "blah" to him", "derive a "ball" from foo", etc.
-# This is strictly speaking, an indirect object, not a direct object.
-# However, it simplfies processing to treat it like a direct object.
-sentence: verb do_preposition(?) article(?) quote io_preposition direct_object
- { &::recent_obj(@{$item[6]});
- { verb => $item[1], quote => $item[4],
- do_preposition => $item[5], direct_object => $item[6] } }
-
-# Now some declarative sentence forms. Matching a possessive object is
-# expensive, so do it only once.
-sentence: possessive_object declaration
- { &::recent_obj(@{$item[1]});
- { direct_object => $item[1], %{$item[2]} } }
-
-# Stuff like "it's not hidden".
-declaration: ess /\bnot\b/i field ...sentence_separator
- { { verb => "is", field => $item[3], negated_verb => 1 } }
-# "it's hidden", etc
-declaration: ess field ...sentence_separator
- { { verb => "is", field => $item[2] } }
-# "I'm not benchmarked"
-declaration: /'?m?\b/i /\bnot\b/i field ...sentence_separator
- { { verb => "am", field => $item[3], negated_verb => 1 } }
-# "I'm benchmarked"
-declaration: /'?m?\b/i field ...sentence_separator
- { { verb => "am", field => $item[2] } }
-# Used, for example, to just say what a field's value is, to set it.
-declaration: field verb quote
- { { field => $item[1], verb => $item[2], quote => $item[3] } }
-# Similar form can be used (by builders) to say that an object's field is a
-# reference to another object.
-declaration: field verb indirect_object
- { { field => $item[1], verb => $item[2], indirect_object => $item[3] } }
-# This is used to set metadata about fields.
-declaration: field verb field number
- { { field => $item[1], verb => $item[2],
- metadata => $item[3], number => $item[4] } }
-# Even a list of references could be set.
-declaration: number field verb indirect_object
- { { number => $item[1], field => $item[2],
- verb => $item[3], indirect_object => $item[4] } }
-# A number can also be given, if there are multiple values of a field.
-declaration: number field verb quote
- { { number => $item[1], field => $item[2],
- verb => $item[3], quote => $item[4] } }
-# This is used to set and unset boolean fields.
-declaration: negated_verb field
- { { verb => $item[1], field => $item[2], negated_verb => 1 } }
-declaration: verb field
- { { verb => $item[1], field => $item[2] } }
-
-# These forms are used by the signal command.
-sentence: verb direct_object preposition(?) number
- { &::recent_obj(@{$item[2]});
- { verb => $item[1], direct_object => $item[2], number => $item[4] } }
-sentence: verb direct_object quote preposition(?) number
- { &::recent_obj(@{$item[2]});
- { verb => $item[1], direct_object => $item[2], quote => $item[3],
- number => $item[5] } }
-
-# And this is is used for dialing telephones. I suppose it could be used
-# for signals too.. Like the verb quote direct_object form, the object is
-# really indirect, but we'll call it the direct object for simplicity.
-sentence: verb do_preposition(?) number io_preposition direct_object
- { &::recent_obj(@{$item[5]});
- { verb => $item[1], number => $item[3],
- do_preposition => $item[4], direct_object => $item[5] } }
-
-# "call me "Fred"", "rename me to "Fred"", etc. Must come after the
-# declarative forms, otherwise the quote matches too freely.
-sentence: verb do_preposition(?) direct_object io_preposition(?) quote
- { &::recent_obj(@{$item[3]});
- { verb => $item[1], do_preposition => $item[2][0],
- direct_object => $item[3], io_preposition => $item[4][0],
- quote => $item[5] } }
-
-# This wacky form is used for digging.
-sentence: verb quote io_preposition quote
- { { verb => $item[1], quote => $item[2], io_preposition => $item[3],
- quote2 => $item[4] } } # XXX there must be a better name than "quote2"?
-
-# These forms are used to do stuff with fields.
-sentence: verb possessive_object field io_preposition quote
- { &::recent_obj(@{$item[2]});
- { verb => $item[1], direct_object => $item[2],
- field => $item[3], quote => $item[5] } }
-sentence: verb possessive_object field io_preposition indirect_object
- { &::recent_obj(@{$item[2]});
- { verb => $item[1], direct_object => $item[2],
- field => $item[3], indirect_object => $item[5] } }
-sentence: verb possessive_object number field io_preposition quote
- { &::recent_obj(@{$item[2]});
- { verb => $item[1], direct_object => $item[2],
- number => $item[3], field => $item[4], quote => $item[6] } }
-
-# For the eval command.
-sentence: verb quote io_preposition field ...sentence_separator
- { { verb => $item[1], quote => $item[2], io_preposition => $item[3],
- field => $item[4] } }
-
-# This is a repeat of the simple sentence form, but it does not require an
-# obvious separator. The only reason for this is to make reinjection work
-# for stuff like "say hi" -- this parses the verb, then the "hi" is quoted
-# and the lot is re-injected.
-# This should be the last sentence type listed.
-sentence: verb
- { { verb => $item[1] } }
-
-# End of the entences, now on to the parts of speech..
-
-direct_object: objectlist
-indirect_object: object
-# Allows for multiple prepositions to be used before a direct object. They
-# are joined together into one.
-do_preposition: preposition(s)
- { join(" ", @{$item[1]}) }
-io_preposition: preposition
-objectlist: object (/(?:(?:,\s*)?and|,)/ object)(s?)
- # Flatten the nested lists into one list ref.
- { [ $item[2] ? ( @{$item[1]}, map { @{$_} } @{$item[2]} ) : @{$item[1]} ] }
-
-# "foo's bar"
-object: basic_object ess object
- { &::is_obj_in_obj($item[3], "", $item[1]) }
-# "my bar"
-object: basic_object object
- { &::is_obj_in_obj($item[2], "", $item[1]) }
-# "bar in foo". Note that multiple prepositions might be used; all must
-# match.
-object: basic_object preposition(s) object
- { &::is_obj_in_obj($item[1], $item[2], $item[3]) }
-# Quantifying the number of objects expected can resolve possible
-# ambiguities.
-object: /(a\b)?/ quantifier /(of\b)?/ object
- { &::check_quantification($item{quantifier}, $item{object}) }
-# Must some after the quantified object test, because "all" could be part
-# of a quantification, or a preposition.
-object: basic_object
-# Another form of quantification, a trifle expensive.
-object: number /(of)?/ basic_object
- { &::check_quantification($item{number}, $item{basic_object}) }
-
-possessive_object: object ess
- { $item[1] }
-
-# This is the set of simple ways to refer to an object, and is used as the
-# base for both regular and possessive forms of objects.
-basic_object: pronoun
- { &::lookup_pronoun($item{pronoun}) }
-basic_object: article(?) /mooix:([^ ]+)/
- { &::lookup_reference($1) }
-basic_object: article(?) adjectivelist noun
- { &::lookup_noun($item{noun}, $item{adjectivelist}) }
-# This version is needed for cases like 'red guest', where red is a known
-# adjective, but it's actually being used as part of the noun instead.
-basic_object: article(?) noun
- { &::lookup_noun($item{noun}) }
-# A production without the article in front, in case the noun seems to strt
-# with an article (probably due to user confusion).
-basic_object: noun
- { &::lookup_noun($item{noun}) }
-
-adjectivelist:
-
-number: /[-+.\w]+\b/
- # lookup_number is passed a textual representation of a number, and
- # should return the number so represented, or undef on error
- { { &::lookup_number($item[1]) } }
-
-# Single or double quoted text. Allow the closing quote to be left off, if
-# the text extends to end of string without one. This also recognizes stuff
-# bracketed by {..} as a quote. This special style is used by the shortcuts
-# substitutions, to unambiguously quote text that may contain other quote
-# characters. Quotes can have a comma before them.
-quote: /,?\s*(?:"([^"]*)(?:"|$)|{(.*)})/ { $1.$2 }
-# Things like object field names. Note that they cannot end in a period;
-# that would be ambiguous with a period at the end of a sentence.
-field: /[-_.+A-Za-z0-9]*[-_+A-Za-z0-9]/
-
-# This only works for verbs like 'is' in declarative sentence forms.
-negated_verb: verb /not\b/i
- { $item[1] }
-negated_verb: /($::verbs)n't\b/i
- { $1 }
-
-# Some of the parts of speech are broken out into variables in main;
-# these variables must be defined before asking the parser to parse
-# something, and can be changed as needed between parsings w/o rebuilding
-# the whole parser. This makes it easy to eg, populate $::nouns with all
-# the names of all the objects the user could refer to. Set the variables
-# to compiled regexp's, that | together the possibilities. Like:
-# $::nouns=qr/cat|dog/;
-preposition: /($::prepositions)\b/i
-adjective: /($::adjectives)\b/i
-noun: /($::nouns)\b/i
-verb: /($::verbs)\b/i
-# The \b is necessary, since "i" is a pronoun, and that could match at the
-# start of other words.
-pronoun: /($::pronouns)\b/i
-# Matches answers to a recent question.
-answer: /($::answers)/i
-quantifier: /($::quantifiers)/i
-
-article: /(an|a|the)\b/i
-coordinating_conjunction: /(and|then|next)\b/i
-ess: /'?s?\b/i
-sentence_punct: /[,;.!]+/
Index: obj/mixin/parser/confused.msg
===================================================================
--- obj/mixin/parser/confused.msg (revision 0)
+++ obj/mixin/parser/confused.msg (revision 0)
@@ -0,0 +1 @@
+I'm sorry, either what you're asking to do isn't possible, or you've managed to confuse me.
Index: obj/mixin/parser/pronouns.inf
===================================================================
--- obj/mixin/parser/pronouns.inf (revision 23)
+++ obj/mixin/parser/pronouns.inf (working copy)
@@ -1,2 +0,0 @@
-This field needs to have a list of every pronoun the parser will
-recognize.
Index: obj/mixin/parser/prepositions
===================================================================
--- obj/mixin/parser/prepositions (revision 23)
+++ obj/mixin/parser/prepositions (working copy)
@@ -1,60 +0,0 @@
-as
-about
-above
-across
-after
-against
-along
-among
-around
-at
-before
-behind
-below
-beneath
-beside
-between
-beyond
-but
-by
-despite
-down
-during
-except
-for
-from
-inside
-into
-in
-like
-near
-off
-of
-onto
-on
-outside
-out
-over
-past
-since
-throughout
-through
-till
-toward
-to
-underneath
-under
-until
-upon
-up
-within
-without
-with
-called
-named
-held
-carried
-away
-using
-front
-top
Index: obj/mixin/parser/compilegrammar
===================================================================
--- obj/mixin/parser/compilegrammar (revision 23)
+++ obj/mixin/parser/compilegrammar (working copy)
@@ -1,20 +1,29 @@
#!/usr/bin/perl
#use Mooix::Thing;
use Parse::RecDescent;
-run sub ($) {
- my $this=shift;
+run sub {
+ my $this=shift;
+ %_ = @_;
+ my $avatar=$_{avatar};
- # Only compile the grammar if it is newer than the compiled form.
- my $gpm = $this->fieldfile("Grammar.pm");
- my $gra = $this->fieldfile("grammar");
- if (! $gpm || (stat($gpm))[9] < (stat($gra))[9]) {
- # Output to "myGrammar", then rename, so the update is atomic.
- Parse::RecDescent->Precompile(scalar $this->grammar, "myGrammar");
- rename("myGrammar.pm", "Grammar.pm") || die "rename: $!";
- # Mark it as a method. This prevents show from trying to display
- # the whole thing..
- chmod(0755, "Grammar.pm");
- }
+ # Only compile the grammar if it is newer than the compiled form.
+ my $gpm = $this->fieldfile("Grammar.pm");
+ my $gra = $avatar->language->fieldfile("grammar");
- return 1;
+ if (! $gpm || (stat($gpm))[9] < (stat($gra))[9]) {
+
+ # Output to "my[code]Grammar", then rename, so the update is atomic.
+ my $gram = "my" . $avatar->language->code . "Grammar";
+ my $pm = $avatar->language->code . "Grammar.pm";
+
+ Parse::RecDescent->Precompile( scalar $avatar->language->grammar, $gram );
+
+ rename( $gram . ".pm", $pm ) || die "rename: $!";
+
+ # Mark it as a method. This prevents show from trying to display
+ # the whole thing..
+ chmod(0755, $pm );
+ }
+
+ return 1;
}
Index: obj/mixin/parser/grammar.inf
===================================================================
--- obj/mixin/parser/grammar.inf (revision 23)
+++ obj/mixin/parser/grammar.inf (working copy)
@@ -1,2 +0,0 @@
-This is a Parse::RecDescent grammar for parsing imperative English
-sentences.
Index: obj/mixin/parser/disambig.msg
===================================================================
--- obj/mixin/parser/disambig.msg (revision 0)
+++ obj/mixin/parser/disambig.msg (revision 0)
@@ -0,0 +1 @@
+Which one of $choices do you mean?
Index: obj/mixin/parser/prepositions.inf
===================================================================
--- obj/mixin/parser/prepositions.inf (revision 23)
+++ obj/mixin/parser/prepositions.inf (working copy)
@@ -1,2 +0,0 @@
-This field needs to have a list of every preposition the parser will
-recognize.
Index: obj/mixin/parser/parse
===================================================================
--- obj/mixin/parser/parse (revision 23)
+++ obj/mixin/parser/parse (working copy)
@@ -13,6 +13,7 @@
#use Mooix::Thing;
#use Mooix::Verb;
#use Mooix::Root;
+use Data::Dumper;
# This is used to mark a Mooix::Thing as coming from a reference.
use constant ISREF => Mooix::Thing::_LAST_FIELD + 1;
@@ -20,184 +21,307 @@
use constant ISAMB => Mooix::Thing::_LAST_FIELD + 2;
# These are referenced by the grammar, and it's up to us to provide them.
-use vars qw{$prepositions $pronouns $adjectives $verbs $nouns $answers
- $quantifiers};
+use vars qw{$prepositions $relative_tags $pronouns $languages $adjectives
+ $verbs $nouns $answers $quantifiers};
-# Some global variables used by the subs below (too many, sigh). #{{{
-our @known; # objects the user might be referring to
-our @all; # object's we're sure the user knows about, that "all"
- # can refer to.
-our %nametoobj; # map names to objects. Hash values are arrays.
-our %adjtoobj; # map adjectives to the objects that have them
-our %pronouns; # map pronouns to objects. Hash values are arrays.
-our $loop; # set to 0 to stop the loop from looping
-our $session; # set to the session that is being parsed for
-our $caller; # set to the avatar that we're acting for
-our $stop; # set to 1 to stop processing of the current command
-our $parser; # parser object
-our $anshandler; # this sub is run if the user seems to aswer a question
-our $timings; # set to true to make timing info be output
-our $failreason; # why a command couldn't be run (short phrase)
-our %incomplete; # if a command can't be run, this holds parts of speech
- # that might be missing
-our $interceptor; # may be set to a command interceptor verb
-our @prompt; # prompt to use for command gathering (optional)
-our $dynprompt; # set if prompt is a method
-our $debugger; # set the the debugger object, if the user is debugging
-#}}}
+# This has actually has its values set by the language object, for
+# use by the grammar. Basically, it lets the language direct the
+# grammar without interference from the "parser".
+use vars qw{%lang_to_grammar};
+# Some global variables used by the subs below (too many, sigh).
+# objects the user might be referring to
+our @known;
+# object's we're sure the user knows about, that "all" can refer to.
+our @all;
+# map names to objects. Hash values are arrays.
+our %nametoobj;
+# map adjectives to the objects that have them
+our %adjtoobj;
+# map pronouns to objects. Hash values are arrays.
+our %pronouns;
+# set to 0 to stop the loop from looping
+our $loop;
+# set to the session that is being parsed for
+our $session;
+# set to the avatar that we're acting for
+our $caller;
+# set to 1 to stop processing of the current command
+our $stop;
+# parser object
+our $parser;
+# this sub is run if the user seems to aswer a question
+our $anshandler;
+# set to true to make timing info be output
+our $timings;
+# why a command couldn't be run (short phrase)
+our $failreason;
+# if a command can't be run, this holds parts of speech
+our %incomplete;
+# that might be missing
+# may be set to a command interceptor verb
+our $interceptor;
+# prompt to use for command gathering (optional)
+our @prompt;
+# set if prompt is a method
+our $dynprompt;
+# set the the debugger object, if the user is debugging
+our $debugger;
+# Ignore all other languages in strings we pull from objects
+our $best_lang_code;
+# The name of the part of the parse tree that the .cmd files are
+# named after.
+our $cmd_parse_command;
+# A list of the names of the parts of the parse tree that return
+# objects and have object-related limits applied to them.
+our @cmd_parse_object;
+# Command substitutions
+our $subst;
+
+sub strip_xml {
+ my $lang_code;
+ $_ = $_[0];
+
+ # If lang code tags are found
+ if( m/]*\1>/ )
+ {
+ my $quote_char = $1;
+ if( m/]*$quote_char>/ )
+ {
+ # If lang code tags of the kind we like are found, use that
+ $lang_code = $best_lang_code;
+ } else {
+ # Else use the first lang code we see
+ m/]*)$quote_char>/;
+ $lang_code = $1;
+ }
+ # Get rid of all text for non-matching lang tags
+ # Does not handle nesting, but shouldn't have to
+ s/]*$quote_char>.*?<\/lang>//g;
+
+ # Get rid of the remaining lang tags.
+ s/]*$quote_char>//g;
+ s/<\/lang>//g;
+ }
+
+ return $_;
+}
+
+
# Examine the environment for settings. This is recalled if the parser is
# hupped.
sub init { #{{{
- # Allow timing info to be output by setting a field in the avatar.
- $timings = $caller->benchmarked;
- $interceptor = $caller->command_interceptor;
- $dynprompt=0;
- if ($caller->defines("prompt")) {
- if ($caller->implements("prompt")) {
- $dynprompt=1;
- # prompt is gathered before every command
- }
- else {
- # gather prompt once
- @prompt = (prompt => $caller->prompt);
- }
+ # There are no answers, at first.
+ $answers = genregex();
+
+ # Let a verb be anything that looks like a word. Starting the
+ # beginning of a sentence is enough of a disambiguator.
+ $verbs = qr/\w+/;
+
+ $best_lang_code=$caller->language->code;
+ $cmd_parse_command = $caller->language->cmd_parse_command;
+ @cmd_parse_object = $caller->language->cmd_parse_object;
+
+ # Set up a few of the parts of speech that don't change
+ # dynamically. These are referenced by the grammar.
+ $prepositions = genregex($caller->language->prepositions);
+ $relative_tags = genregex($caller->language->relative_tags);
+ $pronouns = genregex($caller->language->pronouns);
+
+ # Get the language to set up some more complicate stuff for us
+ my $gv = $caller->language->fieldfile("grammar_variables");
+
+ if( $gv )
+ {
+ do $gv;
+ }
+
+ # Use the languages list thus generated.
+ $languages = genregex( @{$lang_to_grammar{languages}} );
+
+ # To cut down on startup speed, use the precompiled Grammar.pm, unless
+ # the grammar file is newer.
+ my $gram = $caller->language->code . "Grammar";
+ my $gpm = $caller->fieldfile( $gram . ".pm" );
+ my $gra = $caller->language->fieldfile( "grammar" );
+
+ if (! $gpm || (stat($gpm))[9] < (stat($gra))[9]) {
+ $session->write("Compiling grammar, please wait..");
+ $caller->parser_compilegrammar( avatar => $caller );
+ $gpm = $caller->fieldfile( $gram . ".pm" );
+ }
+ do $gpm; #sorta gross, but what the hey
+
+ # It's "my[code]Grammar" because that's the module name used. See
+ # compilegrammar.
+ my $gram2 = "my" . $caller->language->code . "Grammar";
+ $parser = $gram2->new;
+
+ # Load in file and compile a sub to do preparsing substitutions.
+ $subst = eval 'sub { $_=shift;'.$caller->parser_shortcuts."\n".';$_}';
+ if ($@) {
+ $subst = sub {return shift}; # do nothing sub
+ warn "shortcuts broken: $@";
+ }
+
+ # Allow timing info to be output by setting a field in the avatar.
+ $timings = $caller->benchmarked;
+ $interceptor = $caller->command_interceptor;
+ $dynprompt=0;
+ if ($caller->fieldfile("prompt")) {
+ if ($caller->implements("prompt")) {
+ # prompt is gathered before every command
+ $dynprompt=1;
+ } else {
+ # gather prompt once
+ @prompt = (prompt => $caller->prompt);
}
- # Turn debugging on or off.
- if ($caller->debugging && $caller->defines("debug")) {
- $caller->debugger($debugger = $caller->debug);
+ }
+
+ # Check the caller's language as well.
+ if ($caller->language->fieldfile("prompt")) {
+ if ($caller->language->implements("prompt")) {
+ # prompt is gathered before every command
+ $dynprompt=2;
+ } else {
+ # gather prompt once
+ @prompt = (prompt => $caller->language->prompt);
}
- else {
- $caller->debugger($debugger = '');
- }
+ }
+
+ # Turn debugging on or off.
+ if ($caller->debugging && $caller->defines("debug")) {
+ $caller->debugger($debugger = $caller->debug);
+ }
+ else {
+ $caller->debugger($debugger = '');
+ }
} #}}}
# Build up and return a list of nearby objects the caller might know about.
# The order of this is signifiicant, since the first matching object gets
# to run a command. Also sets up the @all list.
sub nearbyobjs { #{{{
- my %contentsseen;
- my @ret=($caller);
- @all=();
+ my %contentsseen;
+ my @ret=($caller);
+ @all=();
- if ($caller->contents) {
- $contentsseen{$caller->index}=1;
- push @all, grep ref, $caller->contents->list;
- push @ret, @all;
+ if ($caller->contents) {
+ $contentsseen{$caller->index}=1;
+ push @all, grep ref, $caller->contents->list;
+ push @ret, @all;
+ }
+ my $loc=$caller->location;
+ if ($loc) {
+ # Add the location near to front. Simple commands like "look"
+ # are handled by the location often.
+ $contentsseen{$loc->index}=1;
+ my @list=grep ref, $loc->contents->list;
+ push @ret, $loc, @list;
+ push @all, @list;
+
+ # If the caller's location is itself located somewhere,
+ # drill down to that uber-location, and add its contents.
+ # This makes things work properly while you're sitting on
+ # furniture, etc.
+ if ($loc->location) {
+ while ($loc->location) {
+ $loc=$loc->location;
+ }
+ $contentsseen{$loc->index}=1;
+ @list = grep ref, $loc->contents->list;
+ push @ret, $loc, @list;
+ push @all, @list;
}
- my $loc=$caller->location;
- if ($loc) {
- # Add the location near to front. Simple commands like "look"
- # are handled by the location often.
- $contentsseen{$loc->index}=1;
- my @list=grep ref, $loc->contents->list;
- push @ret, $loc, @list;
- push @all, @list;
+ }
- # If the caller's location is itself located somewhere,
- # drill down to that uber-location, and add its contents.
- # This makes things work properly while you're sitting on
- # furniture, etc.
- if ($loc->location) {
- while ($loc->location) {
- $loc=$loc->location;
- }
- $contentsseen{$loc->index}=1;
- @list = grep ref, $loc->contents->list;
- push @ret, $loc, @list;
- push @all, @list;
- }
+ # Recursively add the contents of every container to the list.
+ foreach (@ret) {
+ if (! $contentsseen{$_->index} && $_->contents) {
+ $contentsseen{$_->index}=1;
+ # Newly added objects will be processed as part of
+ # this very same loop.
+ push @ret, grep ref, $_->accessible_contents;
}
-
- # Recursively add the contents of every container to the list.
- foreach (@ret) {
- if (! $contentsseen{$_->index} && $_->contents) {
- next if $_->closed && ! $_->transparent;
-
- $contentsseen{$_->index}=1;
- # Newly added objects will be processed as part of
- # this very same loop.
- push @ret, grep ref, $_->contents->list;
- }
- }
-
- return @ret;
+ }
+
+ return @ret;
} #}}}
# Given a noun, return an object or objects that match it.
sub lookup_noun { #{{{
- my $noun = lc(shift);
- my $adjectives = shift;
-
- return unless exists $nametoobj{$noun};
-
- my %seen;
- my @matches;
- my $allplural = 1;
- if ($adjectives && @{$adjectives} > 0) {
- # Use adjectives to disambiguate. Return all objects that
- # match all the adjectives and have the right name.
- my %count;
- foreach my $adj (@{$adjectives}) {
- if (exists $adjtoobj{$adj}) {
- map { $count{$_}++ } @{$adjtoobj{$adj}};
- }
- }
- foreach (@{$nametoobj{$noun}}) {
- if (exists $count{$_->[0]} &&
- $count{$_->[0]} == @{$adjectives} &&
- ! $seen{$_->[0]->index}) {
- $seen{$_->[0]->index}=1;
- push @matches, $_->[0];
- $allplural = 0 if $allplural && ! $_->[1];
- }
- }
+ my $noun = lc(shift);
+ my $adjectives = shift;
+
+ return unless exists $nametoobj{$noun};
+
+ my %seen;
+ my @matches;
+ my $allplural = 1;
+ if ($adjectives && @{$adjectives} > 0) {
+ # Use adjectives to disambiguate. Return all objects that
+ # match all the adjectives and have the right name.
+ my %count;
+ foreach my $adj (@{$adjectives}) {
+ if (exists $adjtoobj{$adj}) {
+ map { $count{$_}++ } @{$adjtoobj{$adj}};
+ }
}
- else {
- foreach (@{$nametoobj{$noun}}) {
- if (! $seen{$_->[0]->index}) {
- $seen{$_->[0]->index}=1;
- push @matches, $_->[0];
- $allplural = 0 if $allplural && ! $_->[1];
- }
- }
+ foreach (@{$nametoobj{$noun}}) {
+ if (exists $count{$_->[0]} &&
+ $count{$_->[0]} == @{$adjectives} &&
+ ! $seen{$_->[0]->index}) {
+ $seen{$_->[0]->index}=1;
+ push @matches, $_->[0];
+ $allplural = 0 if $allplural && ! $_->[1];
+ }
}
+ }
+ else {
+ foreach (@{$nametoobj{$noun}}) {
+ if (! $seen{$_->[0]->index}) {
+ $seen{$_->[0]->index}=1;
+ push @matches, $_->[0];
+ $allplural = 0 if $allplural && ! $_->[1];
+ }
+ }
+ }
- if (@matches > 1 && ! $allplural) {
- # Mark ambiguities.
- my @new;
- my @ambs = map { $_->index } @matches;
- foreach my $o (@matches) {
- # Create a new object pointing at the same real
- # object, so this one can be marked ambiguous
- # without it polluting other refs to the same
- # object.
- $_=bless([@{$o}], ref $o);
- $_->[ISAMB] = \@ambs;
- push @new, $_;
- }
- return \@new;
+ if (@matches > 1 && ! $allplural) {
+ # Mark ambiguities.
+ my @new;
+ my @ambs = map { $_->index } @matches;
+ foreach my $o (@matches) {
+ # Create a new object pointing at the same real
+ # object, so this one can be marked ambiguous
+ # without it polluting other refs to the same
+ # object.
+ $_=bless([@{$o}], ref $o);
+ $_->[ISAMB] = \@ambs;
+ push @new, $_;
}
-
- return (@matches ? \@matches : undef);
+ return \@new;
+ }
+
+ return (@matches ? \@matches : undef);
} #}}}
# Given a pronoun, return an object or objects that match it.
sub lookup_pronoun { #{{{
- my $pronoun = lc(shift);
- return $pronouns{$pronoun} if exists $pronouns{$pronoun};
+ my $pronoun = lc(shift);
+ return $pronouns{$pronoun} if exists $pronouns{$pronoun};
- # Non-pre-calculated pronouns.
- if ($pronoun =~ /everythings?/ || $pronoun eq 'all') {
- my @ret = grep { ! $_->hidden && $_ != $caller } @all;
- return \@ret if @ret;
- }
- elsif ($pronoun eq 'here') {
- # There may be no location.
- my $loc=$caller->location;
- return [$loc] if $loc;
- }
- return;
+ # Non-pre-calculated pronouns.
+ if( grep /^$pronoun$/, $caller->language->all_pronouns )
+ {
+ my @ret = grep { ! $_->hidden && $_ != $caller } @all;
+ return \@ret if @ret;
+ } elsif( grep /^$pronoun$/, $caller->language->here_pronouns ) {
+ # There may be no location.
+ my $loc=$caller->location;
+ return [$loc] if $loc;
+ }
+ return;
} #}}}
# Given an object reference (sans the leading "mooix"), return
@@ -210,94 +334,109 @@
# if it fails.. But the memoization needs to be undone after each
# command that is run, since any command could change the result.
sub lookup_reference { #{{{
- my $id = shift;
- my $obj = $caller->reference(id => $id);
- if ($obj) {
- $obj->[ISREF] = 1;
- return [$obj];
- }
- return;
+ my $id = shift;
+ my $obj = $caller->reference(id => $id);
+ if ($obj) {
+ $obj->[ISREF] = 1;
+ return [$obj];
+ }
+ return;
} #}}}
-# Given a number representation (which might be the raw number, or the
-# written-out form, or some ordinal form), return the number it
-# represents, or undef if none.
-my $word2num_loaded=0;
-sub lookup_number { #{{{
- my $word=shift;
- if (! $word2num_loaded) {
- # Try to use Lingua::EN::Words2Nums, but don't depend
- # on it being installed.
- eval "use Lingua::EN::Words2Nums";
- if ($@) {
- # Install stub function that only does simple numbers.
- *::words2nums = sub {
- $_ = shift;
- return $1 if /^(\d+)(?:st|nd|rd|th)?$/;
- return;
- };
- }
- $word2num_loaded=1;
- }
- # This is a hack, for "next alias is" type of things.
- return 9999 if lc $word eq 'next';
- return words2nums($word);
-} #}}}
+## # Given a number representation (which might be the raw number, or the
+## # written-out form, or some ordinal form), return the number it
+## # represents, or undef if none.
+## my $word2num_loaded=0;
+## sub lookup_number { #{{{
+## my $word=shift;
+## if (! $word2num_loaded) {
+## # Try to use Lingua::EN::Words2Nums, but don't depend
+## # on it being installed.
+## eval "use Lingua::EN::Words2Nums";
+## if ($@) {
+## # Install stub function that only does simple numbers.
+## *::words2nums = sub {
+## $_ = shift;
+## return $1 if /^(\d+)(?:st|nd|rd|th)?$/;
+## return;
+## };
+## }
+## $word2num_loaded=1;
+## }
+## # This is a hack, for "next alias is" type of things.
+## return 9999 if lc $word eq 'next';
+## return words2nums($word);
+## } #}}}
+##
+## # Called by the grammar to point out recently referred to objects that may
+## # set the 'it' pronoun, etc. Pass in a list of objects.
+## sub recent_obj { #{{{
+## my @objs = @_;
+## if (@objs == 1) {
+## # Don't set "it" if the caller talks about themself.
+## $pronouns{that} = $pronouns{thats} = $pronouns{it} =
+## $pronouns{its} = \@objs
+## unless $objs[0] == $caller;
+## my $gender=$objs[0]->gender;
+## if ($gender) {
+## $pronouns{$gender->object_pronoun} = \@objs;
+## }
+## $pronouns
+## }
+## elsif (@objs) {
+## # TODO To be strictly correct, I should only set 'these' and
+## # 'those' if all the objects are not people, and always set
+## # 'them'.
+## $pronouns{these} = $pronouns{those} = $pronouns{them} =
+## $pronouns{their} = \@objs;
+## }
+## } #}}}
-# Called by the grammar to point out recently referred to objects that may
-# set the 'it' pronoun, etc. Pass in a list of objects.
-sub recent_obj { #{{{
- my @objs = @_;
- if (@objs == 1) {
- # Don't set "it" if the caller talks about themself.
- $pronouns{that} = $pronouns{thats} = $pronouns{it} =
- $pronouns{its} = \@objs
- unless $objs[0] == $caller;
- my $gender=$objs[0]->gender;
- if ($gender) {
- $pronouns{$gender->object_pronoun} = \@objs;
- }
- $pronouns
- }
- elsif (@objs) {
- # TODO To be strictly correct, I should only set 'these' and
- # 'those' if all the objects are not people, and always set
- # 'them'.
- $pronouns{these} = $pronouns{those} = $pronouns{them} =
- $pronouns{their} = \@objs;
- }
-} #}}}
-
# Returns an object if it is inside some other object.
# (Actually, it might be called for several objects.)
sub is_obj_in_obj { #{{{
- my @objs=@{shift()};
- my $prepositions=shift;
- my $container=@{shift()}[0];
-
- my @ret;
+ my @objs=@{shift()};
+ my $relative_tag=shift;
+ my $container=@{shift()}[0];
+ ## print STDERR "is_obj relative_tag: $relative_tag \n";
+
+ my @ret;
OBJ: foreach (@objs) {
- # If there are prepositions, make sure that the
- # prepositions can indeed be used. If so, it'll be in
- # the object's preposition list.
- if (ref $prepositions) {
- my %preps = map { $_ => 1 } $_->preposition;
- foreach (@$prepositions) {
- next OBJ unless $preps{$_};
- }
+ # If there is a relative clause tag, make sure that it's
+ # correct for the relationship the object has to its
+ # container.
+ my $ok = 0;
+ if( length $relative_tag ) {
+ my $relative_field = $_->relation . "_relatives";
+ ## print STDERR "is_obj field: $relative_field\n";
+ foreach $_ ($caller->language->$relative_field)
+ {
+ ## print STDERR "relative: " . $_ . "\n";
+ if( $_ eq $relative_tag )
+ {
+ $ok = 1;
+ last;
+ }
}
-
- if ($_->location == $container) {
- push @ret, $_;
- }
+ }
+
+ if( ! $ok )
+ {
+ next OBJ;
+ }
+
+ if ($_->location == $container) {
+ push @ret, $_;
+ }
}
-
+
# Telling where an object is this way can serve to disambiguate
# it, if it was ambiguous.
if (@ret == 1) {
- $ret[0]->[ISAMB] = undef;
+ $ret[0]->[ISAMB] = undef;
}
-
+
+ ## print STDERR "is_obj ret: " . join( ' ', @ret ) . "\n";
return \@ret if @ret;
return;
} #}}}
@@ -307,131 +446,187 @@
# in the prototype, and if the protoype specifies an allowable value set,
# the value must be in that set.
sub checkproto { #{{{
- my $this = shift;
- my $multobj = shift;
- my %command = @_;
+ my $this = shift;
+ my $multobj = shift;
+ my %command = @_;
- my $cmdfield;
- if (exists $command{verb}) {
- $cmdfield = lc($command{verb}).".cmd";
+ my $cmdfield;
+
+ #print STDERR "command: " . Dumper(\%command) . ".\n";
+
+ # First try .cmd.[lang], then try .cmd
+ foreach my $cmd_extension ( ".cmd.".$caller->language->code, ".cmd",)
+ {
+ if( exists $command{$cmd_parse_command} ) {
+ $cmdfield = lc($command{$cmd_parse_command}).$cmd_extension;
+ } else {
+ # Check the default.cmd for weirdly formed commands that
+ # lack a verb.
+ $cmdfield = "default".$cmd_extension;
}
- else {
- # Check the default.cmd for weirdly formed commands that
- # lack a verb.
- $cmdfield = "default.cmd";
- }
if (! $this) {
- use Carp;
- Carp::cluck("called on null object");
+ use Carp;
+ Carp::cluck("called on null object");
}
-
+
PROTO: foreach my $prototype ($this->$cmdfield) {
- my %remains=%command;
+ #print STDERR "prototype: $prototype.\n";
+ my %remains=%command;
- next if $prototype =~ /^#/;
- next unless defined $prototype && length $prototype;
- my ($prototype, $command) = split(/\s*:\s*/, $prototype, 2);
- $command = lc($command{verb}) unless defined $command;
-
- my (@checknearby, @checktouchable, @checkvisible,
+ next if $prototype =~ /^#/;
+ next unless defined $prototype && length $prototype;
+ my ($prototype, $command) = split(/\s*:\s*/, $prototype, 2);
+ $command = lc($command{$cmd_parse_command}) unless defined $command;
+
+ my (@checknearby, @checktouchable, @checkvisible,
@lockpos, @lockmove, @checkopen);
-
- my $fail=0;
- foreach my $section (split(/\s*,\s*/, $prototype)) {
- my ($part, $limits) = $section =~ /(\w+)\s*(?:\((.*)\))?/;
- if (! exists $remains{$part}) {
- $incomplete{$part}=1;
- $fail=1;
- next;
+
+ my $fail=0;
+ foreach my $section (split(/\s*,\s*/, $prototype)) {
+ my ($orig_part, $limits) = $section =~ /([\w=]+)\s*(?:\((.*)\))?/;
+ my ( $part, $name );
+ #print STDERR "part1: $orig_part.\n";
+ # Deal with aliasing
+ if( $orig_part =~ m/=/ )
+ {
+ $orig_part =~ m/(.*)=(.*)/;
+ ( $part, $name ) = ( $1, $2 );
+ if( $remains{$name} )
+ {
+ $remains{$part} = $remains{$name};
+ delete $remains{$name};
+ }
+ } else {
+ $part = $orig_part;
+ $name = $orig_part;
+ }
+ #print STDERR "part2: $part.\n";
+ #print STDERR "remains: " . Dumper(\%remains) . ".\n";
+ if (defined $limits) {
+ #print STDERR "limits: $limits.\n";
+ }
+ if( ! defined $remains{$part} || ! length $remains{$part} ) {
+ # De-alias parts before setting incomplete, so
+ # we can do language-specific failure messages.
+ $incomplete{$name}=1;
+ $fail=1;
+ next;
+ }
+ if (defined $limits) {
+ #print STDERR "in main limits.\n";
+ my $lockpos=0;
+ my $checknearby=0;
+ my $checktouchable=0;
+ my $checkvisible=0;
+ my $checkopen=0;
+ foreach my $limit (split(/\)\(/, $limits)) {
+ my %limit = map { lc($_) => 1 } split(/\s*\|\s*/, $limit);
+ my $ok=0;
+
+ if( $limit =~ m/set@/ )
+ {
+ # For example, preposition must be of a
+ # particular type. So
+ # io_preposition(set@in_prepositions)
+ # matches any prepositions in the
+ # language's in_prepositions field.
+ my $limit_set = $limit;
+ $limit_set =~ s/set@([^|)]*)/$1/;
+ if( grep( /$remains{$part}/, $caller->language->$limit_set ) )
+ {
+ $ok=1;
+ }
}
- if (defined $limits) {
- my $lockpos=0;
- my $checknearby=0;
- my $checktouchable=0;
- my $checkvisible=0;
- my $checkopen=0;
- foreach my $limit (split(/\)\(/, $limits)) {
- my %limit = map { lc($_) => 1 } split(/\s*\|\s*/, $limit);
- my $ok=0;
- if ($part eq 'direct_object' || $part eq 'indirect_object') {
- # Order is important..
- if ($limit{tomove}) {
- push @lockmove, $remains{$part}[0];
- delete $limit{tomove}; # still auto-check nearby
- }
- if ($limit{nearby} || ! %limit) {
- $ok=$lockpos=$checknearby=1;
- }
- if ($limit{touchable}) {
- $ok=$lockpos=$checknearby=$checktouchable=1;
- }
- if ($limit{visible}) {
- $ok=$lockpos=$checknearby=$checkvisible=1;
- }
- if ($limit{reference} && defined $remains{$part}[0]->[ISREF]) {
- $ok=1;
- $checknearby=0;
- }
- if ($limit{single} && (! $multobj || $part ne 'direct_object')) {
- $ok=1;
- }
- if ($limit{anywhere}) {
- $ok=1;
- $checknearby=0;
- }
- if ($limit{this} && $remains{$part}[0] == $this) {
- $ok=1;
- }
- if ($limit{open}) {
- $ok=$checkopen=1;
- }
- }
- elsif ($part eq 'verb') {
- if ($limit{this} && $this == $caller) {
- $ok=1;
- }
- }
- elsif (exists $remains{$part} &&
- defined $remains{$part} &&
- $limit{$remains{$part}}) {
- $ok=1;
- }
- next PROTO unless $ok;
- }
-
- if ($lockpos) {
- push @lockpos, $remains{$part}[0];
- }
- if ($checknearby) {
- push @checknearby, $remains{$part}[0];
- }
- if ($checktouchable) {
- push @checktouchable, $remains{$part}[0];
- }
- if ($checkvisible) {
- push @checkvisible, $remains{$part}[0];
- }
- if ($checkopen) {
- push @checkopen, $remains{$part}[0];
- }
+
+ ## if( grep( /$part/, @cmd_parse_object ) )
+ if ($part eq 'direct_object' || $part eq 'indirect_object')
+ {
+ # Order is important..
+ if ($limit{tomove}) {
+ push @lockmove, $remains{$part}[0];
+ delete $limit{tomove}; # still auto-check nearby
+ }
+ if ($limit{nearby} || ! %limit) {
+ $ok=$lockpos=$checknearby=1;
+ }
+ if ($limit{touchable}) {
+ $ok=$lockpos=$checknearby=$checktouchable=1;
+ }
+ if ($limit{visible}) {
+ $ok=$lockpos=$checknearby=$checkvisible=1;
+ }
+ if ($limit{reference} && defined $remains{$part}[0]->[ISREF]) {
+ $ok=1;
+ $checknearby=0;
+ }
+ if ($limit{single} && (! $multobj || $part ne 'direct_object')) {
+ $ok=1;
+ }
+ if ($limit{anywhere}) {
+ $ok=1;
+ $checknearby=0;
+ }
+ if ($limit{this} && $remains{$part}[0] == $this) {
+ $ok=1;
+ }
+ if ($limit{open}) {
+ $ok=$checkopen=1;
+ }
+ } elsif( $part eq $cmd_parse_command ) {
+ if ($limit{this} && $this == $caller) {
+ $ok=1;
+ }
+ } elsif (exists $remains{$part} &&
+ defined $remains{$part} &&
+ $limit{$remains{$part}}) {
+ # This section handles stuff
+ # like do_preposition(down),
+ # which matches only if the
+ # literal word "down" is in
+ # there as a do_preposition.
+ $ok=1;
}
+ next PROTO unless $ok;
+ }
- delete $remains{$part};
+ if ($lockpos) {
+ push @lockpos, $remains{$part}[0];
+ }
+ if ($checknearby) {
+ push @checknearby, $remains{$part}[0];
+ }
+ if ($checktouchable) {
+ push @checktouchable, $remains{$part}[0];
+ }
+ if ($checkvisible) {
+ push @checkvisible, $remains{$part}[0];
+ }
+ if ($checkopen) {
+ push @checkopen, $remains{$part}[0];
+ }
}
- delete $remains{do_preposition};
- delete $remains{io_preposition};
- if ($fail) {
- if (%remains) {
- %incomplete=();
- }
- next;
+
+ delete $remains{$part};
+ }
+
+ #print STDERR "remains after most stuff: " . Dumper(\%remains) . ".\n";
+
+ clean_remains( \%command, \%remains );
+
+ #print STDERR "remains after all stuff: " . Dumper(\%remains) . ".\n";
+ if ($fail) {
+ if (%remains) {
+ %incomplete=();
}
- #print STDERR "$this $cmdfield remains: ".join(", ", keys %remains)."\n";
- return ($command, \@checknearby , \@checktouchable, \@checkvisible,
- \@lockpos, \@lockmove, \@checkopen) unless %remains;
+ next;
+ }
+ #print STDERR "$this $cmdfield remains: ".join(", ", keys %remains)."\n";
+ return ($command, \@checknearby , \@checktouchable, \@checkvisible,
+ \@lockpos, \@lockmove, \@checkopen, $prototype) unless %remains;
}
- return; # failure
+ }
+ return; # failure
} #}}}
# Given a reference to a sentence and a list of objects, constructs a
@@ -442,284 +637,362 @@
# objects are pretty much indistinguishable, and a good question cannot be
# constructed.
sub gen_disambiguator { #{{{
- my %sentence=%{shift @_};
- my @objs=@_;
-
- # Build up a hash of possible answers to the question.
- # It'll be used by the returned subroutine.
- my %answers;
+ my $object_type = shift;
+ my %sentence=%{shift @_};
+ my @objs=@_;
- # Support "the former" and "the latter" style responses, and
- # "both".
- if (@objs == 2) {
- $answers{former} = [ $objs[0] ];
- $answers{latter} = [ $objs[1] ];
- $answers{both} = [ @objs ]; # XXX would it be better to use the quantifier sub here?
+ # Build up a hash of possible answers to the question.
+ # It'll be used by the returned subroutine.
+ my %answers;
+
+ # Support "the former" and "the latter" style responses, and
+ # "both".
+ if (@objs == 2) {
+ $answers{former} = [ $objs[0] ];
+ $answers{latter} = [ $objs[1] ];
+ $answers{both} = [ @objs ]; # XXX would it be better to use the quantifier sub here?
+ }
+
+ # Let's see if the locations of the objects vary; if so they could
+ # be used to help disambiguate. The hash values will hold the names
+ # of the locations.
+ my %locs;
+ foreach my $obj (@objs) {
+ my $loc=$obj->location;
+ next if ! $loc;
+ my $id=$loc->id;
+ if (! exists $locs{$id}) {
+ my $article = strip_xml( $loc->article );
+ $locs{$id} = strip_xml( $article ) ." " if length strip_xml( $article );
+ $locs{$id} .= strip_xml( $loc->name );
}
-
- # Let's see if the locations of the objects vary; if so they could
- # be used to help disambiguate. The hash values will hold the names
- # of the locations.
- my %locs;
- foreach my $obj (@objs) {
- my $loc=$obj->location;
- next if ! $loc;
- my $id=$loc->id;
- if (! exists $locs{$id}) {
- my $article = $loc->article;
- $locs{$id} = "$article " if length $article;
- $locs{$id} .= $loc->name;
- }
+ }
+
+ # It's quite possible that two objects have nothing really to
+ # distinguish them. So, this hash will be used to keep track of
+ # unique choices.
+ my %seen;
+ # And this array will hold the arrays of objects that each choice
+ # corresponds to.
+ my @choices;
+ my $count=0;
+ foreach my $obj (@objs) {
+ #print STDERR "obj: ".Dumper($obj)."\n";
+ my $bit="";
+
+ if( length strip_xml( $obj->article ) )
+ {
+ # The reason to ignore the object's stated article and use
+ # the definate article is because it looks weird if it asks
+ # "Do you mean the red ball or a green ball".
+ $bit .= $caller->language->definate_article;
}
- # It's quite possible that two objects have nothing really to
- # distinguish them. So, this hash will be used to keep track of
- # unique choices.
- my %seen;
- # And this array will hold the arrays of objects that each choice
- # corresponds to.
- my @choices;
- my $count=0;
- foreach my $obj (@objs) {
- my $bit="";
- # The reason to ignore the object's stated article and use
- # "the" is because it looks weird if it asks "Do you mean
- # the red ball or a green ball".
- $bit .= "the " if length $obj->article;
- my @adj=$obj->adjective;
- # Add the adjectives to the answers list.
- map { push @{$answers{$_}}, $obj } @adj;
- $bit .= join(" ", @adj)." " if @adj;
- $bit .= $obj->name;
- if (scalar keys %locs > 1) {
- my $loc = $obj->location;
- if ($loc == $caller) {
- $bit .= " you're holding";
- }
- else {
- my @prep=$obj->preposition;
- my $prep=$prep[0];
- $prep = "in" if ! length $prep;
- $bit .= " $prep ".$locs{$loc->id};
- }
- }
+ my @adj = map { strip_xml( $_ ) } $obj->adjective;
- if (! $seen{$bit}) {
- $seen{$bit} = 1;
- push @choices, $bit;
- push @{$answers{++$count}}, $obj;
- }
+ # Add the adjectives to the answers list.
+ map { push @{$answers{$_}}, $obj } @adj;
+
+ #print STDERR "bit1: ".Dumper($bit)."\n";
+ $bit .= join(" ", @adj)." " if @adj;
+ #print STDERR "bit2: ".Dumper($bit)."\n";
+ $bit .= strip_xml( $obj->name );
+ #print STDERR "obj name: ".Dumper($obj->name)."\n";
+ #print STDERR "obj name2: ".Dumper( strip_xml( $obj->name ) )."\n";
+ #print STDERR "bit3: ".Dumper($bit)."\n";
+ if (scalar keys %locs > 1) {
+ my $loc = $obj->location;
+ if ($loc == $caller) {
+ $bit .= $caller->language->holding_postfix;
+ }
+ else {
+ # Generate relative clause lists like "The box which
+ # is under the table".
+ my $relation=$obj->relation;
+ my $relative_field_name = $relation . "_relatives";
+ my @relative_field=$caller->language->$relative_field_name;
+ my $relative=$relative_field[0];
+ $bit .= " $relative " .
+ $locs{$loc->id} . " " . $caller->language->relative_ender;
+ }
}
-
- # Do all objects seem to be identical?
- return undef if @choices == 1;
- # Register the answers and the handler.
- $answers=genregex(keys %answers);
- $anshandler=sub {
- my %response = @_;
-
- my $selected;
- if (exists $response{direct_object}) {
- # Trim the list down to the objects in @objs.
- my %objs = map { $_->index => $_ } @objs;
- $selected = [ grep { $objs{$_->index} } @{$response{direct_object}} ];
- }
- elsif (exists $response{number} && exists $answers{$response{number}}) {
- $selected = $answers{$response{number}};
- }
- elsif (exists $response{answer}) {
- my $answer = $response{answer};
- # Check each of the user's responses against the
- # answers, and select any that match them all.
- my $first = shift @$answer;
- my @sel = @{$answers{lc $first}};
- foreach my $a (@{$answer}) {
- my %matches = map { $_->index => 1}
- @{$answers{lc($a)}};
- @sel = grep { $matches{$_->index} } @sel;
- }
- if (! @sel) {
- $session->write("None of the choices is ".
- join(" and ", $first, @{$answer}).".");
- return 1;
- }
- $selected = [ @sel ];
- }
+ #print STDERR "bit: ".Dumper($bit)."\n";
+ if (! $seen{$bit}) {
+ $seen{$bit} = 1;
+ push @choices, $bit;
+ push @{$answers{++$count}}, $obj;
+ }
+ }
- if (! $selected) {
- $session->write("Invalid selection.");
- return 1; # question was anwered, though not well
- }
+ # Do all objects seem to be identical?
+ return undef if @choices == 1;
- # Register the objects as recently referred to objects now.
- recent_obj(@{$selected});
-
- # There may be multiple objects still, and this may well lead
- # to another round of disambiguation.. anyway, the user has
- # answered the question, so deregister it.
- $answers=genregex();
- $anshandler=undef;
- do_multobj_sentence(%sentence, direct_object => $selected);
- return 1; # question was answered, maybe not well
- };
-
- $choices[-1]="or ".$choices[-1];
- return "Do you mean ".join((@choices > 2) ? ', ' : ' ', @choices)."?";
+ #print STDERR "choices1: ".Dumper(\@choices)."\n";
+
+ # Register the answers and the handler.
+ $answers=genregex(keys %answers);
+ print STDERR "answers: ".Dumper(\$answers)."\n";
+ $anshandler=sub {
+ my %response = @_;
+ print STDERR "In anshandler: ".Dumper(\%response).".\n";
+
+ my $selected;
+ if (exists $response{$object_type}) {
+ # Trim the list down to the objects in @objs.
+ my %objs = map { $_->index => $_ } @objs;
+ $selected = [ grep { $objs{$_->index} } @{$response{$object_type}} ];
+ }
+ elsif (exists $response{number} && exists $answers{$response{number}}) {
+ $selected = $answers{$response{number}};
+ }
+ elsif (exists $response{answer}) {
+ my $answer = $response{answer};
+ # Check each of the user's responses against the
+ # answers, and select any that match them all.
+ my $first = shift @$answer;
+ my @sel = @{$answers{lc $first}};
+ foreach my $a (@{$answer}) {
+ my %matches = map { $_->index => 1}
+ @{$answers{lc($a)}};
+ @sel = grep { $matches{$_->index} } @sel;
+ }
+ if (! @sel) {
+ $session->write("None of the choices is ".
+ join(" and ", $first, @{$answer}).".");
+ return 1;
+ }
+ $selected = [ @sel ];
+ }
+
+ if (! $selected) {
+ $session->write("Invalid selection.");
+ return 1; # question was anwered, though not well
+ }
+
+ # Register the objects as recently referred to objects now.
+ $lang_to_grammar{recent_obj}->(@{$selected});
+
+ # There may be multiple objects still, and this may well lead
+ # to another round of disambiguation.. anyway, the user has
+ # answered the question, so deregister it.
+ $answers=genregex();
+ $anshandler=undef;
+ my %new_sentence = %sentence;
+ delete $new_sentence{$object_type};
+ do_multobj_sentence(%new_sentence, $object_type, $selected);
+ return 1; # question was answered, maybe not well
+ };
+
+ my $choices_string = $#choices > 0
+ ? join(
+ $caller->language->list_seperator,
+ @choices[0 .. $#choices-1]
+ )
+ . $caller->language->list_seperator_last
+ . $choices[-1]
+ : $choices[0];
+
+ #$choices[-1]="or ".$choices[-1];
+
+ #print STDERR "choices2: ".Dumper(\@choices)."\n";
+
+ # Hack together the message
+ my $msg_field = 'parser_disambig.msg';
+ my $msg = strip_xml( $caller->$msg_field );
+ $msg =~ s/\$choices/$choices_string/;
+
+ return $msg;
+ #return "Do you mean ".join((@choices > 2) ? ', ' : ' ', @choices)."?";
} #}}}
# This takes care of a sentence that has multiple direct objects in it.
# Detecting ambiguously referred to direct objects and properly dispatching
# everything is a mite complicated.
sub do_multobj_sentence { #{{{
- my %sentence = @_;
-
+ my %sentence = @_;
+ #print STDERR "In do_multiobj: ".Dumper(\%sentence).".\n";
+
+ foreach my $object_type (@cmd_parse_object)
+ {
+ #print STDERR "In do_multiobj foreach: $object_type.\n";
# Putting things in a hash prevents operating on the same direct
# object twice.
- my %dobjs = map { $_->index => $_ } @{$sentence{direct_object}};
-
+ my %my_objs = map { $_->index => $_ } @{$sentence{$object_type}};
+
+ if (scalar values %my_objs <= 1) {
+ if( @{$sentence{$object_type}} == 0 )
+ {
+ delete $sentence{$object_type};
+ }
+ next;
+ }
+
# Check to see if there are any possibly ambiguous references to
# objects.
my $first_time = 1;
- my @list=values %dobjs;
- foreach my $direct_object (@list) {
- next unless $direct_object->[ISAMB];
- if ($first_time && $direct_object->[ISAMB] &&
- grep { $_ ne $direct_object->index && $dobjs{$_} } @{$direct_object->[ISAMB]}) {
- # Check to see which of the direct objects this
- # sentence can actually be run on, and ignore the
- # rest. That might elminiate the ambiguities. It is
- # a bit expensive though.
- $first_time = 0;
- foreach my $direct_object (values %dobjs) {
- # Test, don't do it.
- if (! do_sentence(0, 0, "", %sentence, direct_object => [ $direct_object ])) {
- delete $dobjs{$direct_object->index};
- }
- }
- last if ! %dobjs; # whoops, none can be used.
+ my @list=values %my_objs;
+ foreach my $object (@list) {
+ next unless $object->[ISAMB];
+ if ($first_time && $object->[ISAMB] &&
+ grep { $_ ne $object->index && $my_objs{$_} } @{$object->[ISAMB]}) {
+ # Check to see which of the direct objects this
+ # sentence can actually be run on, and ignore the
+ # rest. That might elminiate the ambiguities. It is
+ # a bit expensive though.
+ $first_time = 0;
+ foreach my $object (values %my_objs) {
+ # Test, don't do it.
+ if (! do_sentence(0, 0, "", %sentence, $object_type => [ $object ])) {
+ delete $my_objs{$object->index};
+ }
}
- if ($direct_object && $dobjs{$direct_object->index} &&
- grep { $_ ne $direct_object->index && $dobjs{$_} } @{$direct_object->[ISAMB]}) {
- my @possibles=map { $dobjs{$_} } grep { $dobjs{$_} } @{$direct_object->[ISAMB]};
- my $disambiguator=gen_disambiguator(\%sentence, @possibles);
- if (! defined $disambiguator) {
- # Act on only one of the objects, since
- # they are all much the same.
- $session->write("(Picking one of them at random ...)");
- return do_sentence(1, 0, '', %sentence, direct_object => [ $possibles[rand @possibles] ]);
- }
- else {
- $session->write($disambiguator);
- # The ISAMB flag needs to be unset now; these
- # objects might be used again and it shouldn't
- # taint them.
- $_->[ISAMB] = undef foreach @list;
- return;
- }
+ last if ! %my_objs; # whoops, none can be used.
+ }
+ if ($object && $my_objs{$object->index} &&
+ grep { $_ ne $object->index && $my_objs{$_} } @{$object->[ISAMB]}) {
+ my @possibles=map { $my_objs{$_} } grep { $my_objs{$_} } @{$object->[ISAMB]};
+ print STDERR "In do_multiobj disam.\n";
+ my $disambiguator=gen_disambiguator( $object_type, \%sentence, @possibles);
+ if (! defined $disambiguator) {
+ # Act on only one of the objects, since
+ # they are all much the same.
+ $session->write("(Picking one of them at random ...)");
+ return do_sentence(1, 0, '', %sentence, $object_type => [ $possibles[rand @possibles] ]);
}
- $direct_object->[ISAMB] = undef; # not any more
+ else {
+ $session->write($disambiguator);
+ # The ISAMB flag needs to be unset now; these
+ # objects might be used again and it shouldn't
+ # taint them.
+ $_->[ISAMB] = undef foreach @list;
+ print STDERR "In do_multiobj disam still.\n";
+ return;
+ }
+ }
+ $object->[ISAMB] = undef; # not any more
}
+ print STDERR "In do_multiobj done foreach.\n";
- if (! %dobjs) {
- showfailure("", %sentence);
- return;
+ if (! %my_objs) {
+ print STDERR "In do_multiobj showfailure.\n";
+ showfailure("", %sentence);
+ return;
}
-
- if (scalar values %dobjs == 1) {
- # There is only one d.o. left after deduping and so on.
- if (! do_sentence(1, 0, '', %sentence, direct_object => [ values %dobjs ])) {
- showfailure('', %sentence, direct_object => [ values %dobjs ]);
- return;
- }
- return 1;
+ }
+
+ foreach my $object_type (@cmd_parse_object)
+ {
+ my %my_objs = map { $_->index => $_ } @{$sentence{$object_type}};
+
+ if (scalar values %my_objs < 1) {
+ if( @{$sentence{$object_type}} == 0 )
+ {
+ delete $sentence{$object_type};
+ }
+ next;
}
+ if (scalar values %my_objs == 1) {
+ # There is only one d.o. left after deduping and so on.
+ if (! do_sentence(1, 0, '', %sentence, $object_type => [ values %my_objs ])) {
+ showfailure('', %sentence, $object_type => [ values %my_objs ]);
+ return;
+ }
+ return 1;
+ }
+
# Do the sentence once per direct object. Do it in the original order
# the user requested, skipping items that aren't in the hash. Delay
# failures until end; if everything failed just show one failure.
my @failed;
my $tried = 0;
- foreach my $direct_object (@{$sentence{direct_object}}) {
- next unless $dobjs{$direct_object->index};
- $tried++;
- if (! do_sentence(1, 1, $direct_object->name.": ", %sentence, direct_object => [ $direct_object ])) {
- push @failed, $direct_object;
- }
- # Don't operate on this object again..
- delete $dobjs{$direct_object->index};
+ foreach my $object (@{$sentence{$object_type}}) {
+ next unless $my_objs{$object->index};
+ $tried++;
+ if (! do_sentence(1, 1, strip_xml( $object->name ).": ", %sentence, $object_type => [ $object ])) {
+ push @failed, $object;
+ }
+ # Don't operate on this object again..
+ delete $my_objs{$object->index};
}
if (@failed) {
- if (@failed == $tried) {
- showfailure("", %sentence, direct_object => $sentence{direct_object}->[0]);
- }
- else {
- showfailure($_->name.": ", %sentence, direct_object => [ $_ ])
- foreach @failed;
- }
- return;
+ if (@failed == $tried) {
+ showfailure("", %sentence, $object_type => $sentence{$object_type}->[0]);
+ }
+ else {
+ showfailure( strip_xml( $_->name ).": ", %sentence, $object_type => [ $_ ])
+ foreach @failed;
+ }
+ return;
}
else {
- return 1;
+ return 1;
}
+ }
} #}}}
-
+
# Given a sentence finds the object that can handle the command and runs
# it. Returns true if something could be done, and false otherwise.
sub do_sentence { #{{{
- my $reallydo = shift; # set if the command should really be executed
+ my $reallydo = shift; # set if the command should really be executed
my $multobj = shift; # set if there are really multiple d.o.'s
my $prefix = shift; # prefix text to display before output
my %sentence = @_;
-
- my @objs=@known;
-
- # The caller's command_intercept can, as a special case, intercept
- # *anything*.
- if (defined $interceptor && length $interceptor) {
- my $ret=runcommand($caller, $interceptor, \%sentence);
- return $ret if $ret;
+
+ my @objs=@known;
+
+ # The caller's command_intercept can, as a special case, intercept
+ # *anything*.
+ if (defined $interceptor && length $interceptor) {
+ my $ret=runcommand($caller, $interceptor, \%sentence);
+ return $ret if $ret;
+ }
+
+ # First, look for verbs on the direct or indirect object. Doing
+ # this first optimizes for the common case. It also means that is
+ # the direct or indirect object was referred to using mooix:, and
+ # is not nearby, they still can have verbs run on them.
+ if ($sentence{direct_object} && @{$sentence{direct_object}}) {
+ if (dispatch($reallydo, $multobj, $sentence{direct_object}->[0], $prefix, %sentence)) {
+ return 1;
}
-
- # First, look for verbs on the direct or indirect object. Doing
- # this first optimizes for the common case. It also means that is
- # the direct or indirect object was referred to using mooix:, and
- # is not nearby, they still can have verbs run on them.
- if ($sentence{direct_object} && @{$sentence{direct_object}}) {
- if (dispatch($reallydo, $multobj, $sentence{direct_object}->[0], $prefix, %sentence)) {
- return 1;
- }
- @objs=grep { $_ != $sentence{direct_object} } @objs;
+ @objs=grep { $_ != $sentence{direct_object} } @objs;
+ }
+ elsif ($sentence{indirect_object} && @{$sentence{indirect_object}}) {
+ if (dispatch($reallydo, $multobj, $sentence{indirect_object}->[0], $prefix, %sentence)) {
+ return 1;
}
- elsif ($sentence{indirect_object} && @{$sentence{indirect_object}}) {
- if (dispatch($reallydo, $multobj, $sentence{indirect_object}->[0], $prefix, %sentence)) {
- return 1;
- }
- @objs=grep { $_ != $sentence{indirect_object} } @objs;
+ @objs=grep { $_ != $sentence{indirect_object} } @objs;
+ }
+
+ # Failing all the above, just try checking all other nearby objects.
+ foreach my $obj (@objs) {
+ if (dispatch($reallydo, $multobj, $obj, $prefix, %sentence)) {
+ return 1;
}
-
- # Failing all the above, just try checking all other nearby objects.
- foreach my $obj (@objs) {
- if (dispatch($reallydo, $multobj, $obj, $prefix, %sentence)) {
- return 1;
- }
+ }
+
+ # If we have only a verb and a preposition, then it could be that
+ # instead of a preposition, they meant to refer to an object. For
+ # example, "go down" causes down to be parsed as a preposition.
+ if (! grep { $_ ne 'verb' && $_ ne 'preposition' } keys %sentence) {
+ my $direct_object = lookup_noun(
+ $caller->dexml(
+ text => $sentence{preposition},
+ language => $best_lang_code
+ )
+ );
+ if ($direct_object) {
+ return do_sentence($reallydo, 0, $prefix,
+ verb => $sentence{verb},
+ direct_object => $direct_object);
}
+ }
- # If we have only a verb and a preposition, then it could be that
- # instead of a preposition, they meant to refer to an object. For
- # example, "go down" causes down to be parsed as a preposition.
- if (! grep { $_ ne 'verb' && $_ ne 'preposition' } keys %sentence) {
- my $direct_object = lookup_noun($sentence{preposition});
- if ($direct_object) {
- return do_sentence($reallydo, 0, $prefix,
- verb => $sentence{verb},
- direct_object => $direct_object);
- }
- }
-
- return; # failure
+ return; # failure
} #}}}
-
+
# This is called when the user's command cannot be run for some reason. If
# $failreason is set, then it is just displayed, telling them why whatever
# they wanted to do can't work. If it is empty, then if %incomplete has
@@ -729,418 +1002,472 @@
# The first parameter is an optional prefix to prepend to the output.
# The sentence is required.
sub showfailure { #{{{
- my $prefix = shift;
- my %sentence = @_;
- $prefix = "" unless defined $prefix;
- # These parts of speech almost never matter.
- delete $incomplete{io_preposition};
- delete $incomplete{do_preposition};
-
- if (length $failreason) {
- $session->write($prefix.$failreason);
- }
- elsif (%incomplete) {
- # Build up a question indicating what parts of speech they
- # were missing.
- my @message;
- if (! $sentence{verb}) {
- # Whee, they typed something really weird.
- $session->write("Beg pardon?");
- return;
- }
- elsif ($incomplete{direct_object}) {
- push @message, $sentence{verb}, "what";
- if ($incomplete{indirect_object}) {
- push @message, "where";
- }
+ my $prefix = shift;
+ my %sentence = @_;
+ $prefix = "" unless defined $prefix;
- # Set up answer handler.
- $anshandler=sub {
- my %response = @_;
- if (exists $response{direct_object}) {
- $sentence{direct_object} = $response{direct_object};
- recent_obj(@{$response{direct_object}});
- $answers=genregex();
- $anshandler=undef;
- do_multobj_sentence(%sentence);
- return 1;
+ if (length $failreason) {
+ $session->write($prefix.$failreason);
+ } elsif (%incomplete) {
+ # Build up a question indicating what parts of speech they
+ # were missing.
+ my @message;
+ if (! $sentence{$cmd_parse_command}) {
+ # Whee, they typed something really weird.
+ my $msg_field = 'parser_wtf.msg';
+ $session->write(
+ strip_xml( $caller->$msg_field )
+ );
+ return;
+ } elsif( grep { exists $incomplete{$_} } @cmd_parse_object ) {
+ foreach my $part (@cmd_parse_object)
+ {
+ if ($incomplete{$part}) {
+ push @message, $sentence{$cmd_parse_command};
+
+ my $question_word = 'question_word_'.$part;
+ push @message, $caller->language->$question_word;
+
+ # Set up answer handler.
+ $anshandler=sub {
+ my %response = @_;
+ if( exists $response{$part} ) {
+
+ # This part allows us to grab extra
+ # fields associated with the object,
+ # like the associated preposition.
+ my $extra_parts_field = $part.'_extras';
+ foreach my $extra_part ($caller->language->$extra_parts_field)
+ {
+ if( exists $response{$extra_part} ) {
+ $sentence{$extra_part} = $response{$extra_part};
}
- return;
- };
- }
- elsif ($incomplete{indirect_object}) {
- push @message, $sentence{verb};
- push @message, "it";
- push @message, "where";
-
- # Set up answer handler.
- $anshandler=sub {
- my %response = @_;
- if (exists $response{direct_object}) {
- $sentence{indirect_object} = $response{direct_object};
- recent_obj(@{$response{direct_object}});
- $sentence{io_preposition} = $response{do_preposition}
- if exists $response{do_preposition};
- $answers=genregex();
- $anshandler=undef;
- do_multobj_sentence(%sentence);
- return 1;
- }
- return;
- };
- }
- else {
- $session->write("You need to supply ".
- join(" and ", map { s/_/ /g; "a $_" }
- keys %incomplete).".");
+ }
+ $sentence{$part} = $response{$part};
+ $lang_to_grammar{recent_obj}->(@{$response{$part}});
+ $answers=genregex();
+ $anshandler=undef;
+ do_multobj_sentence(%sentence);
+ return 1;
+ }
return;
+ };
+
+ last;
}
- $session->write(ucfirst join(" ", @message)."?");
+
+ }
+ } else {
+ my @incompletes = map { clean_incomplete( $_ ) } keys %incomplete;
+
+ my $incompletes_string = $#incompletes > 0
+ ? $caller->language->indefinate_article .
+ join(
+ $caller->language->list_seperator .
+ $caller->language->indefinate_article ,
+ @incompletes[0 .. $#incompletes-1]
+ )
+ . $caller->language->list_seperator_last
+ . $caller->language->indefinate_article . $incompletes[-1]
+ : $caller->language->indefinate_article . $incompletes[0];
+
+ # Hack together the message
+ my $msg_field = 'parser_supply.msg';
+ my $msg = strip_xml( $caller->$msg_field );
+ $msg =~ s/\$incompletes/$incompletes_string/;
+ $session->write($msg);
+
+ return;
}
- else {
- $session->write($prefix."You can't do that.");
+
+ my $message = join(" ", @message);
+ $message = $caller->language->question_starter . $message . $caller->language->question_ender;
+
+ if( $caller->language->upper_case_initial )
+ {
+ $message = ucfirst $message;
}
+
+ $session->write( $message );
+ } else {
+ # Hack together the message
+ my $msg_field = 'parser_confused.msg';
+ my $msg = strip_xml( $caller->$msg_field );
+ $session->write($msg);
+ }
} #}}}
# Tries to find a prototype in an object to match a command, and if it
# finds one, does necessary locking, runs the command and returns true.
sub dispatch { #{{{
- my $reallydo = shift; # really lock and run command
+ my $reallydo = shift; # really lock and run command
my $multobj = shift; # set if there are really multiple d.o's
my $this = shift; # object to check
my $prefix = shift; # prefix text to display before output
my %sentence = @_; # the parameters of the command
my ($command, $checknearby, $checktouchable, $checkvisible,
- $lockpos, $lockmove, $checkopen) =
- checkproto($this, $multobj, %sentence);
- return 0 unless defined $command;
-
- # Now we have to lock some objects in position, and maybe
- # check to make sure they're still nearby (to avoid races).
- #
- # Keeps locks open until the function returns, and keeps
- # track of what is locked.
- my %locked;
+ $lockpos, $lockmove, $checkopen, $prototype) =
+ checkproto($this, $multobj, %sentence);
+ return 0 unless defined $command;
+ #print STDERR "dispactch: $command, $checknearby, $checktouchable, $checkvisible, $lockpos, $lockmove, $checkopen.\n";
- if ($reallydo) {
- # First, handle any objects that need to be locked for move.
- # This is an exclusive lock.
- foreach my $obj (@{$lockmove}) {
- next if $locked{$obj->index};
- return unless $locked{$obj->index} =
- $obj->getlock(LOCK_EX);
- }
+ # Now we have to lock some objects in position, and maybe
+ # check to make sure they're still nearby (to avoid races).
+ #
+ # Keeps locks open until the function returns, and keeps
+ # track of what is locked.
+ my %locked;
- # Then, lock any remaining objects that need to be locked,
- # to prevent moving by third parties. This is a shared lock.
- foreach my $obj (@{$lockpos}) {
- next if $locked{$obj->index};
- return unless $locked{$obj->index} =
- $obj->getlock(LOCK_SH);
- }
+ if ($reallydo) {
+ # First, handle any objects that need to be locked for move.
+ # This is an exclusive lock.
+ foreach my $obj (@{$lockmove}) {
+ next if $locked{$obj->index};
+ return unless $locked{$obj->index} =
+ $obj->getlock(LOCK_EX);
}
-
- # The caller's location.
- my $cloc=$caller->location;
- # If the caller's location is itself in some location, use its
- # location.
- while ($cloc && $cloc->location) {
- $cloc = $cloc->location;
+
+ # Then, lock any remaining objects that need to be locked,
+ # to prevent moving by third parties. This is a shared lock.
+ foreach my $obj (@{$lockpos}) {
+ next if $locked{$obj->index};
+ return unless $locked{$obj->index} =
+ $obj->getlock(LOCK_SH);
}
-
- # Check to see if objects that must be touchable are. That means
- # that every container between the user and the object must be
- # open.
- foreach my $obj (@{$checktouchable}) {
- my $loc=$obj->location;
- if (! $loc) {
- next if $cloc == $obj;
- return;
- }
- while ($loc && ($loc != $caller && $cloc != $loc && $cloc != $obj)) {
- # The container the object is in needs to be locked
- # in position to prevent it from being moved in
- # the middle of a command.
- if ($locked{$obj->index}) {
- if (! $locked{$loc->index}) {
- $locked{$loc->index} = $loc->getlock(LOCK_SH);
- }
- }
- # And the container must be locked open, to prevent
- # it from closing during the command.
- if ($loc && ! $locked{"closed".$loc->index}) {
- $locked{"closed".$loc->index} = $loc->getlock(LOCK_SH, "closed");
- }
- # Only check its state after taking the lock.
- if (! $loc || $loc->closed) {
- $failreason="You can't touch that.";
- return;
- }
- $loc=$loc->location; # advance to next container
- }
- return unless $loc;
+ }
+
+ # The caller's location.
+ my $cloc=$caller->location;
+ # If the caller's location is itself in some location, use its
+ # location.
+ while ($cloc && $cloc->location) {
+ $cloc = $cloc->location;
+ }
+
+ # Check to see if objects that must be touchable are. That means
+ # that every container between the user and the object must be
+ # open, or the objects must be otherwise accessible.
+ foreach my $obj (@{$checktouchable}) {
+ my $loc=$obj->location;
+ if (! $loc) {
+ next if $cloc == $obj;
+ return;
}
-
- # Check to see if objects that must be nearby are.
- foreach my $obj (@{$checknearby}) {
- my $loc=$obj->location;
- if (! $loc) {
- next if $cloc == $obj;
- return;
+ while ($loc && ($loc != $caller && $cloc != $loc && $cloc != $obj)) {
+ # The container the object is in needs to be locked
+ # in position to prevent it from being moved in
+ # the middle of a command.
+ if ($locked{$obj->index}) {
+ if (! $locked{$loc->index}) {
+ $locked{$loc->index} = $loc->getlock(LOCK_SH);
}
- while ($loc && ($loc != $caller && $cloc != $loc && $cloc != $obj)) {
- # The container the object is in needs to be locked
- # in position to prevent it from being mov