base/parse.c

   1 /*
   2  * base code for various Tcl extensions
   3  * Copyright 2006-2012 Ian Jackson
   4  *
   5  * This program is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU General Public License as
   7  * published by the Free Software Foundation; either version 2 of the
   8  * License, or (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful, but
  11  * WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  * General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this library; if not, see <http://www.gnu.org/licenses/>.
  17  */
  18
  19 #include "chiark-tcl-base.h"
  20
  21 int cht_pat_charfrom(Tcl_Interp *ip, Tcl_Obj *obj, int *val,
  22                  const char *opts, const char *what) {
  23   *val= cht_enum1_lookup_cached_func(ip,obj,opts,what);
  24   if (*val==-1) return TCL_ERROR;
  25   return TCL_OK;
  26 }
  27
  28 int cht_pat_int(Tcl_Interp *ip, Tcl_Obj *obj, int *val) {
  29   return Tcl_GetIntFromObj(ip, obj, val);
  30 }
  31
  32 int cht_pat_long(Tcl_Interp *ip, Tcl_Obj *obj, long *val) {
  33   return Tcl_GetLongFromObj(ip, obj, val);
  34 }
  35
  36 int cht_pat_string(Tcl_Interp *ip, Tcl_Obj *obj, const char **val) {
  37   *val= Tcl_GetString(obj);
  38   return TCL_OK;
  39 }
  40
  41 int cht_pat_constv(Tcl_Interp *ip, Tcl_Obj *var,
  42                Tcl_Obj **val_r, Tcl_ObjType *type) {
  43   int rc;
  44   Tcl_Obj *val;
  45
  46   val= Tcl_ObjGetVar2(ip,var,0,TCL_LEAVE_ERR_MSG);
  47   if (!val) return TCL_ERROR;
  48
  49   if (type) {
  50     rc= Tcl_ConvertToType(ip,val,type);
  51     if (rc) return rc;
  52   }
  53
  54   *val_r= val;
  55   return TCL_OK;
  56 }
  57
  58 void cht_init_somethingv(Something_Var *sth) {
  59   sth->obj=0; sth->var=0; sth->copied=0;
  60 }
  61
  62 int cht_pat_somethingv(Tcl_Interp *ip, Tcl_Obj *var,
  63                    Something_Var *sth, Tcl_ObjType *type) {
  64   int rc;
  65   Tcl_Obj *val;
  66
  67   sth->var= var;
  68
  69   val= Tcl_ObjGetVar2(ip,var,0,TCL_LEAVE_ERR_MSG);
  70   if (!val) return TCL_ERROR;
  71
  72   rc= Tcl_ConvertToType(ip,val,type);
  73   if (rc) return rc;
  74
  75   if (Tcl_IsShared(val)) {
  76     val= Tcl_DuplicateObj(val);
  77     sth->copied= 1;
  78   }
  79   Tcl_InvalidateStringRep(val);
  80   sth->obj= val;
  81
  82   return TCL_OK;
  83 }
  84
  85 void cht_fini_somethingv(Tcl_Interp *ip, int rc, Something_Var *sth) {
  86   Tcl_Obj *ro;
  87
  88   if (!rc) {
  89     assert(sth->obj);
  90     ro= Tcl_ObjSetVar2(ip,sth->var,0,sth->obj,TCL_LEAVE_ERR_MSG);
  91     if (!ro) rc= TCL_ERROR;
  92   }
  93   if (rc && sth->copied)
  94     Tcl_DecrRefCount(sth->obj);
  95 }
  96
  97 Tcl_Obj *cht_ret_long(Tcl_Interp *ip, long val) {
  98   return Tcl_NewLongObj(val);
  99 }
 100
 101 Tcl_Obj *cht_ret_string(Tcl_Interp *ip, const char *val) {
 102   return Tcl_NewStringObj(val,-1);
 103 }