/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclget.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclget.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 64 by dashley, Sun Oct 30 04:21:11 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
1  /* $Header$ */  /* $Header$ */
2  /*  /*
3   * tclGet.c --   * tclGet.c --
4   *   *
5   *      This file contains procedures to convert strings into   *      This file contains procedures to convert strings into
6   *      other forms, like integers or floating-point numbers or   *      other forms, like integers or floating-point numbers or
7   *      booleans, doing syntax checking along the way.   *      booleans, doing syntax checking along the way.
8   *   *
9   * Copyright (c) 1990-1993 The Regents of the University of California.   * Copyright (c) 1990-1993 The Regents of the University of California.
10   * Copyright (c) 1994-1997 Sun Microsystems, Inc.   * Copyright (c) 1994-1997 Sun Microsystems, Inc.
11   *   *
12   * See the file "license.terms" for information on usage and redistribution   * See the file "license.terms" for information on usage and redistribution
13   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14   *   *
15   * RCS: @(#) $Id: tclget.c,v 1.1.1.1 2001/06/13 04:39:21 dtashley Exp $   * RCS: @(#) $Id: tclget.c,v 1.1.1.1 2001/06/13 04:39:21 dtashley Exp $
16   */   */
17    
18  #include "tclInt.h"  #include "tclInt.h"
19  #include "tclPort.h"  #include "tclPort.h"
20  #include "tclMath.h"  #include "tclMath.h"
21    
22    
23  /*  /*
24   *----------------------------------------------------------------------   *----------------------------------------------------------------------
25   *   *
26   * Tcl_GetInt --   * Tcl_GetInt --
27   *   *
28   *      Given a string, produce the corresponding integer value.   *      Given a string, produce the corresponding integer value.
29   *   *
30   * Results:   * Results:
31   *      The return value is normally TCL_OK;  in this case *intPtr   *      The return value is normally TCL_OK;  in this case *intPtr
32   *      will be set to the integer value equivalent to string.  If   *      will be set to the integer value equivalent to string.  If
33   *      string is improperly formed then TCL_ERROR is returned and   *      string is improperly formed then TCL_ERROR is returned and
34   *      an error message will be left in the interp's result.   *      an error message will be left in the interp's result.
35   *   *
36   * Side effects:   * Side effects:
37   *      None.   *      None.
38   *   *
39   *----------------------------------------------------------------------   *----------------------------------------------------------------------
40   */   */
41    
42  int  int
43  Tcl_GetInt(interp, string, intPtr)  Tcl_GetInt(interp, string, intPtr)
44      Tcl_Interp *interp;         /* Interpreter to use for error reporting. */      Tcl_Interp *interp;         /* Interpreter to use for error reporting. */
45      char *string;               /* String containing a (possibly signed)      char *string;               /* String containing a (possibly signed)
46                                   * integer in a form acceptable to strtol. */                                   * integer in a form acceptable to strtol. */
47      int *intPtr;                /* Place to store converted result. */      int *intPtr;                /* Place to store converted result. */
48  {  {
49      char *end, *p;      char *end, *p;
50      long i;      long i;
51    
52      /*      /*
53       * Note: use strtoul instead of strtol for integer conversions       * Note: use strtoul instead of strtol for integer conversions
54       * to allow full-size unsigned numbers, but don't depend on strtoul       * to allow full-size unsigned numbers, but don't depend on strtoul
55       * to handle sign characters;  it won't in some implementations.       * to handle sign characters;  it won't in some implementations.
56       */       */
57    
58      errno = 0;      errno = 0;
59      for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */      for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
60          /* Empty loop body. */          /* Empty loop body. */
61      }      }
62      if (*p == '-') {      if (*p == '-') {
63          p++;          p++;
64          i = -((long)strtoul(p, &end, 0)); /* INTL: Tcl source. */          i = -((long)strtoul(p, &end, 0)); /* INTL: Tcl source. */
65      } else if (*p == '+') {      } else if (*p == '+') {
66          p++;          p++;
67          i = strtoul(p, &end, 0); /* INTL: Tcl source. */          i = strtoul(p, &end, 0); /* INTL: Tcl source. */
68      } else {      } else {
69          i = strtoul(p, &end, 0); /* INTL: Tcl source. */          i = strtoul(p, &end, 0); /* INTL: Tcl source. */
70      }      }
71      if (end == p) {      if (end == p) {
72          badInteger:          badInteger:
73          if (interp != (Tcl_Interp *) NULL) {          if (interp != (Tcl_Interp *) NULL) {
74              Tcl_AppendResult(interp, "expected integer but got \"", string,              Tcl_AppendResult(interp, "expected integer but got \"", string,
75                      "\"", (char *) NULL);                      "\"", (char *) NULL);
76              TclCheckBadOctal(interp, string);              TclCheckBadOctal(interp, string);
77          }          }
78          return TCL_ERROR;          return TCL_ERROR;
79      }      }
80    
81      /*      /*
82       * The second test below is needed on platforms where "long" is       * The second test below is needed on platforms where "long" is
83       * larger than "int" to detect values that fit in a long but not in       * larger than "int" to detect values that fit in a long but not in
84       * an int.       * an int.
85       */       */
86    
87      if ((errno == ERANGE) || (((long)(int) i) != i)) {      if ((errno == ERANGE) || (((long)(int) i) != i)) {
88          if (interp != (Tcl_Interp *) NULL) {          if (interp != (Tcl_Interp *) NULL) {
89              Tcl_SetResult(interp, "integer value too large to represent",              Tcl_SetResult(interp, "integer value too large to represent",
90                      TCL_STATIC);                      TCL_STATIC);
91              Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",              Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
92                      Tcl_GetStringResult(interp), (char *) NULL);                      Tcl_GetStringResult(interp), (char *) NULL);
93          }          }
94          return TCL_ERROR;          return TCL_ERROR;
95      }      }
96      while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */      while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */
97          end++;          end++;
98      }      }
99      if (*end != 0) {      if (*end != 0) {
100          goto badInteger;          goto badInteger;
101      }      }
102      *intPtr = (int) i;      *intPtr = (int) i;
103      return TCL_OK;      return TCL_OK;
104  }  }
105    
106  /*  /*
107   *----------------------------------------------------------------------   *----------------------------------------------------------------------
108   *   *
109   * TclGetLong --   * TclGetLong --
110   *   *
111   *      Given a string, produce the corresponding long integer value.   *      Given a string, produce the corresponding long integer value.
112   *      This routine is a version of Tcl_GetInt but returns a "long"   *      This routine is a version of Tcl_GetInt but returns a "long"
113   *      instead of an "int".   *      instead of an "int".
114   *   *
115   * Results:   * Results:
116   *      The return value is normally TCL_OK; in this case *longPtr   *      The return value is normally TCL_OK; in this case *longPtr
117   *      will be set to the long integer value equivalent to string. If   *      will be set to the long integer value equivalent to string. If
118   *      string is improperly formed then TCL_ERROR is returned and   *      string is improperly formed then TCL_ERROR is returned and
119   *      an error message will be left in the interp's result if interp   *      an error message will be left in the interp's result if interp
120   *      is non-NULL.   *      is non-NULL.
121   *   *
122   * Side effects:   * Side effects:
123   *      None.   *      None.
124   *   *
125   *----------------------------------------------------------------------   *----------------------------------------------------------------------
126   */   */
127    
128  int  int
129  TclGetLong(interp, string, longPtr)  TclGetLong(interp, string, longPtr)
130      Tcl_Interp *interp;         /* Interpreter used for error reporting      Tcl_Interp *interp;         /* Interpreter used for error reporting
131                                   * if not NULL. */                                   * if not NULL. */
132      char *string;               /* String containing a (possibly signed)      char *string;               /* String containing a (possibly signed)
133                                   * long integer in a form acceptable to                                   * long integer in a form acceptable to
134                                   * strtoul. */                                   * strtoul. */
135      long *longPtr;              /* Place to store converted long result. */      long *longPtr;              /* Place to store converted long result. */
136  {  {
137      char *end, *p;      char *end, *p;
138      long i;      long i;
139    
140      /*      /*
141       * Note: don't depend on strtoul to handle sign characters; it won't       * Note: don't depend on strtoul to handle sign characters; it won't
142       * in some implementations.       * in some implementations.
143       */       */
144    
145      errno = 0;      errno = 0;
146      for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */      for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
147          /* Empty loop body. */          /* Empty loop body. */
148      }      }
149      if (*p == '-') {      if (*p == '-') {
150          p++;          p++;
151          i = -(int)strtoul(p, &end, 0); /* INTL: Tcl source. */          i = -(int)strtoul(p, &end, 0); /* INTL: Tcl source. */
152      } else if (*p == '+') {      } else if (*p == '+') {
153          p++;          p++;
154          i = strtoul(p, &end, 0); /* INTL: Tcl source. */          i = strtoul(p, &end, 0); /* INTL: Tcl source. */
155      } else {      } else {
156          i = strtoul(p, &end, 0); /* INTL: Tcl source. */          i = strtoul(p, &end, 0); /* INTL: Tcl source. */
157      }      }
158      if (end == p) {      if (end == p) {
159          badInteger:          badInteger:
160          if (interp != (Tcl_Interp *) NULL) {          if (interp != (Tcl_Interp *) NULL) {
161              Tcl_AppendResult(interp, "expected integer but got \"", string,              Tcl_AppendResult(interp, "expected integer but got \"", string,
162                      "\"", (char *) NULL);                      "\"", (char *) NULL);
163              TclCheckBadOctal(interp, string);              TclCheckBadOctal(interp, string);
164          }          }
165          return TCL_ERROR;          return TCL_ERROR;
166      }      }
167      if (errno == ERANGE) {      if (errno == ERANGE) {
168          if (interp != (Tcl_Interp *) NULL) {          if (interp != (Tcl_Interp *) NULL) {
169              Tcl_SetResult(interp, "integer value too large to represent",              Tcl_SetResult(interp, "integer value too large to represent",
170                      TCL_STATIC);                      TCL_STATIC);
171              Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",              Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
172                      Tcl_GetStringResult(interp), (char *) NULL);                      Tcl_GetStringResult(interp), (char *) NULL);
173          }          }
174          return TCL_ERROR;          return TCL_ERROR;
175      }      }
176      while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */      while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */
177          end++;          end++;
178      }      }
179      if (*end != 0) {      if (*end != 0) {
180          goto badInteger;          goto badInteger;
181      }      }
182      *longPtr = i;      *longPtr = i;
183      return TCL_OK;      return TCL_OK;
184  }  }
185    
186  /*  /*
187   *----------------------------------------------------------------------   *----------------------------------------------------------------------
188   *   *
189   * Tcl_GetDouble --   * Tcl_GetDouble --
190   *   *
191   *      Given a string, produce the corresponding double-precision   *      Given a string, produce the corresponding double-precision
192   *      floating-point value.   *      floating-point value.
193   *   *
194   * Results:   * Results:
195   *      The return value is normally TCL_OK; in this case *doublePtr   *      The return value is normally TCL_OK; in this case *doublePtr
196   *      will be set to the double-precision value equivalent to string.   *      will be set to the double-precision value equivalent to string.
197   *      If string is improperly formed then TCL_ERROR is returned and   *      If string is improperly formed then TCL_ERROR is returned and
198   *      an error message will be left in the interp's result.   *      an error message will be left in the interp's result.
199   *   *
200   * Side effects:   * Side effects:
201   *      None.   *      None.
202   *   *
203   *----------------------------------------------------------------------   *----------------------------------------------------------------------
204   */   */
205    
206  int  int
207  Tcl_GetDouble(interp, string, doublePtr)  Tcl_GetDouble(interp, string, doublePtr)
208      Tcl_Interp *interp;         /* Interpreter used for error reporting. */      Tcl_Interp *interp;         /* Interpreter used for error reporting. */
209      char *string;               /* String containing a floating-point number      char *string;               /* String containing a floating-point number
210                                   * in a form acceptable to strtod. */                                   * in a form acceptable to strtod. */
211      double *doublePtr;          /* Place to store converted result. */      double *doublePtr;          /* Place to store converted result. */
212  {  {
213      char *end;      char *end;
214      double d;      double d;
215    
216      errno = 0;      errno = 0;
217      d = strtod(string, &end); /* INTL: Tcl source. */      d = strtod(string, &end); /* INTL: Tcl source. */
218      if (end == string) {      if (end == string) {
219          badDouble:          badDouble:
220          if (interp != (Tcl_Interp *) NULL) {          if (interp != (Tcl_Interp *) NULL) {
221              Tcl_AppendResult(interp,              Tcl_AppendResult(interp,
222                      "expected floating-point number but got \"",                      "expected floating-point number but got \"",
223                      string, "\"", (char *) NULL);                      string, "\"", (char *) NULL);
224          }          }
225          return TCL_ERROR;          return TCL_ERROR;
226      }      }
227      if (errno != 0 && (d == HUGE_VAL || d == -HUGE_VAL || d == 0)) {      if (errno != 0 && (d == HUGE_VAL || d == -HUGE_VAL || d == 0)) {
228          if (interp != (Tcl_Interp *) NULL) {          if (interp != (Tcl_Interp *) NULL) {
229              TclExprFloatError(interp, d);              TclExprFloatError(interp, d);
230          }          }
231          return TCL_ERROR;          return TCL_ERROR;
232      }      }
233      while ((*end != 0) && isspace(UCHAR(*end))) { /* INTL: ISO space. */      while ((*end != 0) && isspace(UCHAR(*end))) { /* INTL: ISO space. */
234          end++;          end++;
235      }      }
236      if (*end != 0) {      if (*end != 0) {
237          goto badDouble;          goto badDouble;
238      }      }
239      *doublePtr = d;      *doublePtr = d;
240      return TCL_OK;      return TCL_OK;
241  }  }
242    
243  /*  /*
244   *----------------------------------------------------------------------   *----------------------------------------------------------------------
245   *   *
246   * Tcl_GetBoolean --   * Tcl_GetBoolean --
247   *   *
248   *      Given a string, return a 0/1 boolean value corresponding   *      Given a string, return a 0/1 boolean value corresponding
249   *      to the string.   *      to the string.
250   *   *
251   * Results:   * Results:
252   *      The return value is normally TCL_OK;  in this case *boolPtr   *      The return value is normally TCL_OK;  in this case *boolPtr
253   *      will be set to the 0/1 value equivalent to string.  If   *      will be set to the 0/1 value equivalent to string.  If
254   *      string is improperly formed then TCL_ERROR is returned and   *      string is improperly formed then TCL_ERROR is returned and
255   *      an error message will be left in the interp's result.   *      an error message will be left in the interp's result.
256   *   *
257   * Side effects:   * Side effects:
258   *      None.   *      None.
259   *   *
260   *----------------------------------------------------------------------   *----------------------------------------------------------------------
261   */   */
262    
263  int  int
264  Tcl_GetBoolean(interp, string, boolPtr)  Tcl_GetBoolean(interp, string, boolPtr)
265      Tcl_Interp *interp;         /* Interpreter used for error reporting. */      Tcl_Interp *interp;         /* Interpreter used for error reporting. */
266      char *string;               /* String containing a boolean number      char *string;               /* String containing a boolean number
267                                   * specified either as 1/0 or true/false or                                   * specified either as 1/0 or true/false or
268                                   * yes/no. */                                   * yes/no. */
269      int *boolPtr;               /* Place to store converted result, which      int *boolPtr;               /* Place to store converted result, which
270                                   * will be 0 or 1. */                                   * will be 0 or 1. */
271  {  {
272      int i;      int i;
273      char lowerCase[10], c;      char lowerCase[10], c;
274      size_t length;      size_t length;
275    
276      /*      /*
277       * Convert the input string to all lower-case.       * Convert the input string to all lower-case.
278       * INTL: This code will work on UTF strings.       * INTL: This code will work on UTF strings.
279       */       */
280    
281      for (i = 0; i < 9; i++) {      for (i = 0; i < 9; i++) {
282          c = string[i];          c = string[i];
283          if (c == 0) {          if (c == 0) {
284              break;              break;
285          }          }
286          if ((c >= 'A') && (c <= 'Z')) {          if ((c >= 'A') && (c <= 'Z')) {
287              c += (char) ('a' - 'A');              c += (char) ('a' - 'A');
288          }          }
289          lowerCase[i] = c;          lowerCase[i] = c;
290      }      }
291      lowerCase[i] = 0;      lowerCase[i] = 0;
292    
293      length = strlen(lowerCase);      length = strlen(lowerCase);
294      c = lowerCase[0];      c = lowerCase[0];
295      if ((c == '0') && (lowerCase[1] == '\0')) {      if ((c == '0') && (lowerCase[1] == '\0')) {
296          *boolPtr = 0;          *boolPtr = 0;
297      } else if ((c == '1') && (lowerCase[1] == '\0')) {      } else if ((c == '1') && (lowerCase[1] == '\0')) {
298          *boolPtr = 1;          *boolPtr = 1;
299      } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) {      } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) {
300          *boolPtr = 1;          *boolPtr = 1;
301      } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) {      } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) {
302          *boolPtr = 0;          *boolPtr = 0;
303      } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) {      } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) {
304          *boolPtr = 1;          *boolPtr = 1;
305      } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) {      } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) {
306          *boolPtr = 0;          *boolPtr = 0;
307      } else if ((c == 'o') && (length >= 2)) {      } else if ((c == 'o') && (length >= 2)) {
308          if (strncmp(lowerCase, "on", length) == 0) {          if (strncmp(lowerCase, "on", length) == 0) {
309              *boolPtr = 1;              *boolPtr = 1;
310          } else if (strncmp(lowerCase, "off", length) == 0) {          } else if (strncmp(lowerCase, "off", length) == 0) {
311              *boolPtr = 0;              *boolPtr = 0;
312          } else {          } else {
313              goto badBoolean;              goto badBoolean;
314          }          }
315      } else {      } else {
316          badBoolean:          badBoolean:
317          if (interp != (Tcl_Interp *) NULL) {          if (interp != (Tcl_Interp *) NULL) {
318              Tcl_AppendResult(interp, "expected boolean value but got \"",              Tcl_AppendResult(interp, "expected boolean value but got \"",
319                      string, "\"", (char *) NULL);                      string, "\"", (char *) NULL);
320          }          }
321          return TCL_ERROR;          return TCL_ERROR;
322      }      }
323      return TCL_OK;      return TCL_OK;
324  }  }
325    
326  /* End of tclget.c */  /* End of tclget.c */
Legend:
Removed from v.64  
changed lines
  Added in v.71
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25