1/* -*- Mode: c++ -*-
2 * $Id: xotclError.c,v 1.5 2006/09/27 08:12:40 neumann Exp $
3 *
4 *  Extended Object Tcl (XOTcl)
5 *
6 *  Copyright (C) 1999-2008 Gustaf Neumann, Uwe Zdun
7 *
8 *
9 *  xotclError.c --
10 *
11 *  error return functions for XOTcl
12 *
13 */
14
15#include "xotclInt.h"
16
17int
18XOTclErrMsg(Tcl_Interp *interp, char *msg, Tcl_FreeProc* type) {
19    Tcl_SetResult(interp, msg, type);
20    return TCL_ERROR;
21}
22
23int
24XOTclVarErrMsg TCL_VARARGS_DEF (Tcl_Interp *, arg1)
25{
26    va_list argList;
27    char *string;
28    Tcl_Interp *interp;
29
30    interp = TCL_VARARGS_START(Tcl_Interp *, arg1, argList);
31    Tcl_ResetResult(interp);
32    while (1) {
33      string = va_arg(argList, char *);
34      if (string == NULL) {
35        break;
36      }
37      Tcl_AppendResult(interp, string, (char *) NULL);
38    }
39    va_end(argList);
40    return TCL_ERROR;
41}
42
43
44int
45XOTclErrInProc (Tcl_Interp *interp, Tcl_Obj *objName,
46		Tcl_Obj *clName, char *procName) {
47    Tcl_DString errMsg;
48    char *cName, *space;
49    ALLOC_DSTRING(&errMsg, "\n    ");
50    if (clName) {
51      cName = ObjStr(clName);
52      space = " ";
53    } else {
54      cName = "";
55      space ="";
56    }
57    Tcl_DStringAppend(&errMsg, ObjStr(objName),-1);
58    Tcl_DStringAppend(&errMsg, space, -1);
59    Tcl_DStringAppend(&errMsg, cName, -1);
60    Tcl_DStringAppend(&errMsg, "->", 2);
61    Tcl_DStringAppend(&errMsg, procName, -1);
62    Tcl_AddErrorInfo (interp, Tcl_DStringValue(&errMsg));
63    DSTRING_FREE(&errMsg);
64    return TCL_ERROR;
65}
66
67int
68XOTclObjErrArgCnt(Tcl_Interp *interp, Tcl_Obj *cmdname, char *arglist) {
69  Tcl_ResetResult(interp);
70  Tcl_AppendResult(interp, "wrong # args: should be {", (char *) NULL);
71  if (cmdname) {
72    Tcl_AppendResult(interp, ObjStr(cmdname), " ", (char *) NULL);
73  }
74  if (arglist != 0) Tcl_AppendResult(interp, arglist, (char *) NULL);
75  Tcl_AppendResult(interp, "}", (char *) NULL);
76  return TCL_ERROR;
77}
78
79int
80XOTclErrBadVal(Tcl_Interp *interp, char *context, char *expected, char *value) {
81  Tcl_ResetResult(interp);
82  Tcl_AppendResult(interp, context, ": expected ", expected, " but got '",
83		   value, "'", (char *) NULL);
84  return TCL_ERROR;
85}
86
87int
88XOTclErrBadVal_(Tcl_Interp *interp, char *expected, char *value) {
89  fprintf(stderr, "Deprecated call, recompile your program with xotcl 1.5 or newer\n");
90  Tcl_ResetResult(interp);
91  Tcl_AppendResult(interp, ": expected ", expected, " but got '",
92		   value, "'", (char *) NULL);
93  return TCL_ERROR;
94}
95
96extern int
97XOTclObjErrType(Tcl_Interp *interp, Tcl_Obj *nm, char *wt) {
98  Tcl_ResetResult(interp);
99  Tcl_AppendResult(interp,"'",ObjStr(nm), "' method should be called on '",
100		   wt, "'", (char *) NULL);
101  return TCL_ERROR;
102}
103