#include "defs.h"
#include "value.h"
#include "gdb_string.h"
#include "varobj.h"
#include <tcl.h>
#include "gdbtk.h"
#include "gdbtk-cmds.h"
int gdb_variable_init (Tcl_Interp *);
static int gdb_variable_command (ClientData, Tcl_Interp *, int,
Tcl_Obj * CONST[]);
static int variable_obj_command (ClientData, Tcl_Interp *, int,
Tcl_Obj * CONST[]);
static int variable_create (Tcl_Interp *, int, Tcl_Obj * CONST[]);
static void variable_delete (Tcl_Interp *, struct varobj *, int);
static Tcl_Obj *variable_children (Tcl_Interp *, struct varobj *);
static int variable_format (Tcl_Interp *, int, Tcl_Obj * CONST[],
struct varobj *);
static int variable_type (Tcl_Interp *, int, Tcl_Obj * CONST[],
struct varobj *);
static int variable_value (Tcl_Interp *, int, Tcl_Obj * CONST[],
struct varobj *);
static Tcl_Obj *variable_update (Tcl_Interp * interp, struct varobj **var);
static void install_variable (Tcl_Interp *, char *);
static void uninstall_variable (Tcl_Interp *, char *);
static char *format_string[] =
{"natural", "binary", "decimal", "hexadecimal", "octal"};
int
gdb_variable_init (Tcl_Interp *interp)
{
Tcl_Command result;
static int initialized = 0;
if (!initialized)
{
result = Tcl_CreateObjCommand (interp, "gdb_variable", gdbtk_call_wrapper,
(ClientData) gdb_variable_command, NULL);
if (result == NULL)
return TCL_ERROR;
initialized = 1;
}
return TCL_OK;
}
static int
gdb_variable_command (ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])
{
static const char *commands[] =
{"create", "list", NULL};
enum commands_enum
{
VARIABLE_CREATE, VARIABLE_LIST
};
int index, result;
if (objc < 2)
{
Tcl_WrongNumArgs (interp, 1, objv, "option ?arg...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj (interp, objv[1], commands, "options", 0,
&index) != TCL_OK)
{
return TCL_ERROR;
}
switch ((enum commands_enum) index)
{
case VARIABLE_CREATE:
result = variable_create (interp, objc - 2, objv + 2);
break;
default:
return TCL_ERROR;
}
return result;
}
static int
variable_obj_command (ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])
{
enum commands_enum
{
VARIABLE_DELETE,
VARIABLE_NUM_CHILDREN,
VARIABLE_CHILDREN,
VARIABLE_FORMAT,
VARIABLE_TYPE,
VARIABLE_VALUE,
VARIABLE_NAME,
VARIABLE_EDITABLE,
VARIABLE_UPDATE
};
static const char *commands[] =
{
"delete",
"numChildren",
"children",
"format",
"type",
"value",
"name",
"editable",
"update",
NULL
};
struct varobj *var;
char *varobj_name;
int index, result;
varobj_name = Tcl_GetStringFromObj (objv[0], NULL);
if (varobj_name == NULL)
return TCL_ERROR;
var = varobj_get_handle (varobj_name);
if (objc < 2)
{
Tcl_WrongNumArgs (interp, 1, objv, "option ?arg...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj (interp, objv[1], commands, "options", 0,
&index) != TCL_OK)
return TCL_ERROR;
result = TCL_OK;
switch ((enum commands_enum) index)
{
case VARIABLE_DELETE:
if (objc > 2)
{
int len;
char *s = Tcl_GetStringFromObj (objv[2], &len);
if (*s == 'c' && strncmp (s, "children", len) == 0)
{
variable_delete (interp, var, 1 );
break;
}
}
variable_delete (interp, var, 0 );
break;
case VARIABLE_NUM_CHILDREN:
Tcl_SetObjResult (interp, Tcl_NewIntObj (varobj_get_num_children (var)));
break;
case VARIABLE_CHILDREN:
{
Tcl_Obj *children = variable_children (interp, var);
Tcl_SetObjResult (interp, children);
}
break;
case VARIABLE_FORMAT:
result = variable_format (interp, objc, objv, var);
break;
case VARIABLE_TYPE:
result = variable_type (interp, objc, objv, var);
break;
case VARIABLE_VALUE:
result = variable_value (interp, objc, objv, var);
break;
case VARIABLE_NAME:
{
char *name = varobj_get_expression (var);
Tcl_SetObjResult (interp, Tcl_NewStringObj (name, -1));
xfree (name);
}
break;
case VARIABLE_EDITABLE:
Tcl_SetObjResult (interp,
Tcl_NewIntObj (varobj_get_attributes (var) & 0x00000001 ));
break;
case VARIABLE_UPDATE:
{
Tcl_Obj *obj = variable_update (interp, &var);
Tcl_SetObjResult (interp, obj);
}
break;
default:
return TCL_ERROR;
}
return result;
}
static int
variable_create (Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
{
enum create_opts
{
CREATE_EXPR, CREATE_FRAME
};
static const char *create_options[] =
{"-expr", "-frame", NULL};
struct varobj *var;
char *name;
char *obj_name;
int index;
CORE_ADDR frame = (CORE_ADDR) -1;
int how_specified = USE_SELECTED_FRAME;
name = NULL;
if (objc)
name = Tcl_GetStringFromObj (objv[0], NULL);
if (name == NULL || *name == '-')
{
obj_name = varobj_gen_name ();
}
else
{
obj_name = strdup (name);
objv++;
objc--;
}
name = NULL;
while (objc > 0)
{
if (Tcl_GetIndexFromObj (interp, objv[0], create_options, "options",
0, &index) != TCL_OK)
{
xfree (obj_name);
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
return TCL_ERROR;
}
switch ((enum create_opts) index)
{
case CREATE_EXPR:
name = Tcl_GetStringFromObj (objv[1], NULL);
objc--;
objv++;
break;
case CREATE_FRAME:
{
char *str;
str = Tcl_GetStringFromObj (objv[1], NULL);
frame = string_to_core_addr (str);
how_specified = USE_SPECIFIED_FRAME;
objc--;
objv++;
}
break;
default:
break;
}
objc--;
objv++;
}
var = varobj_create (obj_name, name, frame, how_specified);
if (var != NULL)
{
install_variable (interp, obj_name);
Tcl_SetObjResult (interp, Tcl_NewStringObj (obj_name, -1));
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
xfree (obj_name);
return TCL_OK;
}
xfree (obj_name);
return TCL_ERROR;
}
static void
variable_delete (Tcl_Interp *interp, struct varobj *var,
int only_children_p)
{
char **dellist;
char **vc;
varobj_delete (var, &dellist, only_children_p);
vc = dellist;
while (*vc != NULL)
{
uninstall_variable (interp, *vc);
xfree (*vc);
vc++;
}
xfree (dellist);
}
static Tcl_Obj *
variable_children (Tcl_Interp *interp, struct varobj *var)
{
Tcl_Obj *list;
struct varobj **childlist;
struct varobj **vc;
char *childname;
list = Tcl_NewListObj (0, NULL);
varobj_list_children (var, &childlist);
vc = childlist;
while (*vc != NULL)
{
childname = varobj_get_objname (*vc);
Tcl_ListObjAppendElement (NULL, list,
Tcl_NewStringObj (childname, -1));
install_variable (interp, childname);
vc++;
}
xfree (childlist);
return list;
}
static Tcl_Obj *
variable_update (Tcl_Interp *interp, struct varobj **var)
{
Tcl_Obj *changed;
struct varobj **changelist;
struct varobj **vc;
if (varobj_update (var, &changelist) == -1)
return Tcl_NewStringObj ("-1", -1);
changed = Tcl_NewListObj (0, NULL);
vc = changelist;
while (*vc != NULL)
{
Tcl_ListObjAppendElement (NULL, changed,
Tcl_NewStringObj (varobj_get_objname (*vc), -1));
vc++;
}
xfree (changelist);
return changed;
}
static int
variable_format (Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[], struct varobj *var)
{
if (objc > 2)
{
int len;
char *fmt = Tcl_GetStringFromObj (objv[2], &len);
if (strncmp (fmt, "natural", len) == 0)
varobj_set_display_format (var, FORMAT_NATURAL);
else if (strncmp (fmt, "binary", len) == 0)
varobj_set_display_format (var, FORMAT_BINARY);
else if (strncmp (fmt, "decimal", len) == 0)
varobj_set_display_format (var, FORMAT_DECIMAL);
else if (strncmp (fmt, "hexadecimal", len) == 0)
varobj_set_display_format (var, FORMAT_HEXADECIMAL);
else if (strncmp (fmt, "octal", len) == 0)
varobj_set_display_format (var, FORMAT_OCTAL);
else
{
gdbtk_set_result (interp, "unknown display format \"",
fmt, "\": must be: \"natural\", \"binary\""
", \"decimal\", \"hexadecimal\", or \"octal\"");
return TCL_ERROR;
}
}
else
{
Tcl_Obj *fmt;
fmt = Tcl_NewStringObj (
format_string[(int) varobj_get_display_format (var)], -1);
Tcl_SetObjResult (interp, fmt);
}
return TCL_OK;
}
static int
variable_type (Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[], struct varobj *var)
{
const char *first;
const char *last;
char *string;
Tcl_RegExp regexp;
if ((string = varobj_get_type (var)) == NULL)
{
Tcl_ResetResult (interp);
return TCL_OK;
}
first = string;
regexp = Tcl_RegExpCompile (interp, "{...}");
if (Tcl_RegExpExec (interp, regexp, string, first))
{
Tcl_RegExpRange (regexp, 0, &first, &last);
if (*(first - 1) == ' ')
first--;
string[first - string] = '\0';
}
Tcl_SetObjResult (interp, Tcl_NewStringObj (string, -1));
xfree (string);
return TCL_OK;
}
static int
variable_value (Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[], struct varobj *var)
{
char *r;
if (objc > 2)
{
if (varobj_get_attributes (var) & 0x00000001 )
{
char *s;
s = Tcl_GetStringFromObj (objv[2], NULL);
if (!varobj_set_value (var, s))
{
gdbtk_set_result (interp, "Could not assign expression to variable object");
return TCL_ERROR;
}
}
Tcl_ResetResult (interp);
return TCL_OK;
}
r = varobj_get_value (var);
if (r == NULL)
{
gdbtk_set_result (interp, "Could not read variable object value after assignment");
return TCL_ERROR;
}
else
{
Tcl_SetObjResult (interp, Tcl_NewStringObj (r, -1));
xfree (r);
return TCL_OK;
}
}
static void
install_variable (Tcl_Interp *interp, char *name)
{
Tcl_CreateObjCommand (interp, name, variable_obj_command,
NULL, NULL);
}
static void
uninstall_variable (Tcl_Interp *interp, char *varname)
{
Tcl_DeleteCommand (interp, varname);
}