path: root/gdb/gdbtk/generic/gdbtk-varobj.c

/* Variable user interface layer for GDB, the GNU debugger.
   Copyright 1999, 2000, 2001, 2002 Free Software Foundation, Inc.

   This file is part of GDB.

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */

#include "defs.h"
#include "value.h"
#include "gdb_string.h"
#include "varobj.h"

#include <tcl.h>
#include "gdbtk.h"
#include "gdbtk-cmds.h"

/*
 * Public functions defined in this file
 */

int gdb_variable_init (Tcl_Interp *);

/*
 * Private functions defined in this file
 */

/* Entries into this file */

static int gdb_variable_command (ClientData, Tcl_Interp *, int,
				 Tcl_Obj * CONST[]);

static int variable_obj_command (ClientData, Tcl_Interp *, int,
				 Tcl_Obj * CONST[]);

/* Variable object subcommands */

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);

/* Helper functions for the above subcommands. */

static void install_variable (Tcl_Interp *, char *);

static void uninstall_variable (Tcl_Interp *, char *);

/* String representations of gdb's format codes */
static char *format_string[] =
  {"natural", "binary", "decimal", "hexadecimal", "octal"};


/* Initialize the variable code. This function should be called once
   to install and initialize the variable code into the interpreter. */
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;
}

/* This function defines the "gdb_variable" command which is used to
   create variable objects. Its syntax includes:

   gdb_variable create
   gdb_variable create NAME
   gdb_variable create -expr EXPR
   gdb_variable create -frame FRAME
   (it will also include permutations of the above options)

   NAME  = name of object to create. If no NAME, then automatically create
   a name
   EXPR  = the gdb expression for which to create a variable. This will
   be the most common usage.
   FRAME = the frame defining the scope of the variable.
*/
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;
}

/* This function implements the actual object command for each
   variable object that is created (and each of its children).

   Currently the following commands are implemented:
   - delete        delete this object and its children
   - update        update the variable and its children (root vars only)
   - numChildren   how many children does this object have
   - children      create the children and return a list of their objects
   - name          print out the name of this variable
   - format        query/set the display format of this variable
   - type          get the type of this variable
   - value         get/set the value of this variable
   - editable      is this variable editable?
*/
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;
  
  /* Get the current handle for this variable token (name). */
  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 /* only children */ );
	      break;
	    }
	}
      variable_delete (interp, var, 0 /* var and children */ );
      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 /* Editable? */ ));
      break;

    case VARIABLE_UPDATE:
      /* Only root variables can be updated */
      {
	Tcl_Obj *obj = variable_update (interp, &var);
	Tcl_SetObjResult (interp, obj);
      }
      break;

    default:
      return TCL_ERROR;
    }

  return result;
}

/*
 * Variable object construction/destruction
 */

/* This function is responsible for processing the user's specifications
   and constructing a variable object. */
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;

  /* REMINDER: This command may be invoked in the following ways:
     gdb_variable create [NAME] [-expr EXPR] [-frame FRAME]

     NAME  = name of object to create. If no NAME, then automatically create
     a name
     EXPR  = the gdb expression for which to create a variable. This will
     be the most common usage.
     FRAME = the address of the frame defining the variable's scope
  */
  name = NULL;
  if (objc)
    name = Tcl_GetStringFromObj (objv[0], NULL);
  if (name == NULL || *name == '-')
    {
      /* generate a name for this object */
      obj_name = varobj_gen_name ();
    }
  else
    {
      /* specified name for object */
      obj_name = strdup (name);
      objv++;
      objc--;
    }

  /* Run through all the possible options for this command */
  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++;
    }

  /* Create the variable */
  var = varobj_create (obj_name, name, frame, how_specified);

  if (var != NULL)
    {
      /* Install a command into the interpreter that represents this
         object */
      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;
}

/* Delete the variable object VAR and its children */
/* If only_children_p, Delete only the children associated with the object. */
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);
}

/* Return a list of all the children of VAR, creating them if necessary. */
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);
      /* Add child to result list and install the Tcl command for it. */
      Tcl_ListObjAppendElement (NULL, list,
				Tcl_NewStringObj (childname, -1));
      install_variable (interp, childname);
      vc++;
    }

  xfree (childlist);
  return list;
}

/* Update the values for a variable and its children. */
/* NOTE:   Only root variables can be updated... */

static Tcl_Obj *
variable_update (Tcl_Interp *interp, struct varobj **var)
{
  Tcl_Obj *changed;
  struct varobj **changelist;
  struct varobj **vc;

  /* varobj_update() can return -1 if the variable is no longer around,
     i.e. we stepped out of the frame in which a local existed. */
  if (varobj_update (var, &changelist) == -1)
    return Tcl_NewStringObj ("-1", -1);

  changed = Tcl_NewListObj (0, NULL);  
  vc = changelist;
  while (*vc != NULL)
    {
      /* Add changed variable object to result list */
      Tcl_ListObjAppendElement (NULL, changed,
				Tcl_NewStringObj (varobj_get_objname (*vc), -1));
      vc++;
    }

  xfree (changelist);
  return changed;
}

/* This implements the format object command allowing
   the querying or setting of the object's display format. */
static int
variable_format (Tcl_Interp *interp, int objc, 
		 Tcl_Obj *CONST objv[], struct varobj *var)
{
  if (objc > 2)
    {
      /* Set the format of VAR to given format */
      int len;
      char *fmt = Tcl_GetStringFromObj (objv[2], &len);
      if (STREQN (fmt, "natural", len))
	varobj_set_display_format (var, FORMAT_NATURAL);
      else if (STREQN (fmt, "binary", len))
	varobj_set_display_format (var, FORMAT_BINARY);
      else if (STREQN (fmt, "decimal", len))
	varobj_set_display_format (var, FORMAT_DECIMAL);
      else if (STREQN (fmt, "hexadecimal", len))
	varobj_set_display_format (var, FORMAT_HEXADECIMAL);
      else if (STREQN (fmt, "octal", len))
	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
    {
      /* Report the current format */
      Tcl_Obj *fmt;

      /* FIXME: Use varobj_format_string[] instead */
      fmt = Tcl_NewStringObj (
			      format_string[(int) varobj_get_display_format (var)], -1);
      Tcl_SetObjResult (interp, fmt);
    }

  return TCL_OK;
}

/* This function implements the type object command, which returns the type of a
   variable in the interpreter (or an error). */
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;

  /* For the "fake" variables, do not return a type.
     Their type is NULL anyway */
  /* FIXME: varobj_get_type() calls type_print(), so we may have to wrap
     its call here and return TCL_ERROR in the case it errors out */
  if ((string = varobj_get_type (var)) == NULL)
    {
      Tcl_ResetResult (interp);
      return TCL_OK;
    }

  first = string;

  /* gdb will print things out like "struct {...}" for anonymous structs.
     In gui-land, we don't want the {...}, so we strip it here. */
  regexp = Tcl_RegExpCompile (interp, "{...}");
  if (Tcl_RegExpExec (interp, regexp, string, first))
    {
      /* We have an anonymous struct/union/class/enum */
      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;
}

/* This function implements the value object command, which allows an object's
   value to be queried or set. */
static int
variable_value (Tcl_Interp *interp, int objc,
		Tcl_Obj *CONST objv[], struct varobj *var)
{
  char *r;

  /* If we're setting the value of the variable, objv[2] will contain the
     variable's new value. */
  if (objc > 2)
    {
      /* FIXME: Do we need to test if val->error is set here?
         If so, make it an attribute. */
      if (varobj_get_attributes (var) & 0x00000001 /* Editable? */ )
	{
	  char *s;

	  s = Tcl_GetStringFromObj (objv[2], NULL);
	  if (!varobj_set_value (var, s))
            {
	      r = error_last_message();
	      gdbtk_set_result (interp, "%s", r);
	      xfree (r);
	      return TCL_ERROR;
            }
	}

      Tcl_ResetResult (interp);
      return TCL_OK;
    }

  r = varobj_get_value (var);

  if (r == NULL)
    {
      char *err = error_last_message ();
      gdbtk_set_result (interp, "%s", err);
      xfree (err);
      return TCL_ERROR;
    }
  else
    {
      Tcl_SetObjResult (interp, Tcl_NewStringObj (r, -1));
      xfree (r);
      return TCL_OK;
    }
}

/* Helper functions for the above */

/* Install the given variable VAR into the tcl interpreter with
   the object name NAME. */
static void
install_variable (Tcl_Interp *interp, char *name)
{
  Tcl_CreateObjCommand (interp, name, variable_obj_command,
			NULL, NULL);
}

/* Unistall the object VAR in the tcl interpreter. */
static void
uninstall_variable (Tcl_Interp *interp, char *varname)
{
  Tcl_DeleteCommand (interp, varname);
}