1 /*
2   Copyright (c) 1997-2004 Nick Ing-Simmons. All rights reserved.
3   This program is free software; you can redistribute it and/or
4   modify it under the same terms as Perl itself.
5 */
6 #define PERL_NO_GET_CONTEXT
7 
8 #include <EXTERN.h>
9 #include <perl.h>
10 #include <XSUB.h>
11 
12 #include "tkGlue.def"
13 
14 #include "pTk/tkPort.h"
15 #include "pTk/tkInt.h"
16 #include "tkGlue.h"
17 
18 #if PERL_REVISION == 5 && PERL_VERSION < 10
19 #define NEED_FIX_BUGGY_UTF8_STRING
20 #endif
21 
22 static int
Expire(int code)23 Expire(int code)
24 {
25  return code;
26 }
27 
28 int
has_highbit(CONST char * s,int l)29 has_highbit(CONST char *s,int l)
30 {
31  CONST char *e = s+l;
32  while (s < e)
33   {
34    if (*s++ & 0x80)
35     return 1;
36   }
37  return 0;
38 }
39 
40 SV *
sv_maybe_utf8(SV * sv)41 sv_maybe_utf8(SV *sv)
42 {
43 #ifdef SvUTF8_on
44  if (SvPOK(sv))
45   {
46    if (has_highbit(SvPVX(sv),SvCUR(sv)))
47     SvUTF8_on(sv);
48   }
49 #endif
50  return sv;
51 }
52 
53 #define EXPIRE(args) \
54   ( Tcl_SprintfResult args, Expire(TCL_ERROR) )
55 
56 /*
57  * This file maps Tcl_Obj * onto perl's SV *
58  * They are very similar.
59  * One area of worry is that Tcl_Obj are created with refCount = 0,
60  * while SV's have SvREFCNT == 1
61  * None the less normal idiom is
62  *
63  *   Tcl_Obj *obj = Tcl_NewFooObj(...)
64  *   ...
65  *   Tcl_DecrRefCount(obj)
66  *
67  * So difference should be transparent.
68  *
69  * Also :
70  *
71  *   Tcl_Obj *obj = Tcl_NewFooObj(...)
72  *   Tcl_ListAppendElement(list,obj);
73  *
74  * Again this is consistent with perl's assumption that refcount is 1
75  * and that av_push() does not increment it.
76  *
77  */
78 
79 int
Tcl_IsShared(Tcl_Obj * objPtr)80 Tcl_IsShared(Tcl_Obj *objPtr)
81 {
82  return SvREFCNT(objPtr) > 1;
83 }
84 
85 void
Tcl_IncrRefCount(Tcl_Obj * objPtr)86 Tcl_IncrRefCount(Tcl_Obj *objPtr)
87 {
88  dTHX;
89  SvREFCNT_inc(objPtr);
90 }
91 
92 void
Tcl_DecrRefCount(Tcl_Obj * objPtr)93 Tcl_DecrRefCount(Tcl_Obj *objPtr)
94 {
95  dTHX;
96  SvREFCNT_dec(objPtr);
97 }
98 
99 static SV *ForceScalar(pTHX_ SV *sv);
100 
101 static SV *ForceScalarLvalue(pTHX_ SV *sv);
102 
103 static void
Scalarize(pTHX_ SV * sv,AV * av)104 Scalarize(pTHX_ SV *sv, AV *av)
105 {
106  int n    = av_len(av)+1;
107  if (n == 0)
108   sv_setpvn(sv,"",0);
109  else
110   {
111    SV **svp;
112    if (n == 1 && (svp = av_fetch(av, 0, 0)))
113     {
114      STRLEN len = 0;
115      char *s  = SvPV(*svp,len);
116 #ifdef SvUTF8
117      int utf8 = SvUTF8(*svp);
118      sv_setpvn(sv,s,len);
119      if (utf8)
120       SvUTF8_on(sv);
121 #else
122      sv_setpvn(sv,s,len);
123 #endif
124     }
125    else
126     {
127      Tcl_DString ds;
128      int i;
129      Tcl_DStringInit(&ds);
130      for (i=0; i < n; i++)
131       {
132        if ((svp = av_fetch(av, i, 0)))
133         {
134          SV *el = *svp;
135          int temp = 0;
136          if (SvROK(el) && !SvOBJECT(SvRV(el)) && SvTYPE(SvRV(el)) == SVt_PVAV)
137           {
138            el = newSVpv("",0);
139            temp = 1;
140            if ((AV *) SvRV(*svp) == av)
141             abort();
142            Scalarize(aTHX_ el,(AV *) SvRV(*svp));
143           }
144          Tcl_DStringAppendElement(&ds,Tcl_GetString(el));
145          if (temp)
146           SvREFCNT_dec(el);
147         }
148       }
149      sv_setpvn(sv,Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
150      sv_maybe_utf8(sv);
151      Tcl_DStringFree(&ds);
152     }
153   }
154 }
155 
156 static SV *
ForceScalar(pTHX_ SV * sv)157 ForceScalar(pTHX_ SV *sv)
158 {
159  if (SvGMAGICAL(sv))
160   mg_get(sv);
161  if (SvTYPE(sv) == SVt_PVAV)
162   {
163    AV *av = (AV *) sv;
164    SV *newsv = newSVpv("",0);
165    Scalarize(aTHX_ newsv, (AV *) av);
166    av_clear(av);
167    av_store(av,0,newsv);
168    return newsv;
169   }
170  else
171   {
172    if (SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV)
173     {
174      /* Callbacks and lists often get stringified by mistake due to
175         Tcl/Tk's string fixation - don't change the real value
176       */
177      SV *newsv = newSVpv("",0);
178      Scalarize(aTHX_ newsv, (AV *) SvRV(sv));
179      return sv_2mortal(newsv);
180     }
181    else if (!SvOK(sv))
182     {
183      /* Map undef to null string */
184      if (SvREADONLY(sv))
185       {
186        SV *newsv = newSVpv("",0);
187        return sv_2mortal(newsv);
188       }
189      else
190       sv_setpvn(sv,"",0);
191     }
192    return sv;
193   }
194 }
195 
196 static SV *
ForceScalarLvalue(pTHX_ SV * sv)197 ForceScalarLvalue(pTHX_ SV *sv)
198 {
199  if (SvTYPE(sv) == SVt_PVAV)
200   {
201    AV *av = (AV *) sv;
202    SV *newsv = newSVpv("",0);
203    av_clear(av);
204    av_store(av,0,newsv);
205    return newsv;
206   }
207  else
208   {
209    return sv;
210   }
211 }
212 
213 void
Tcl_SetBooleanObj(Tcl_Obj * objPtr,int value)214 Tcl_SetBooleanObj (Tcl_Obj *objPtr, int value)
215 {
216  dTHX;
217  sv_setiv(ForceScalarLvalue(aTHX_ objPtr),value != 0);
218 }
219 
220 void
Tcl_SetDoubleObj(Tcl_Obj * objPtr,double value)221 Tcl_SetDoubleObj (Tcl_Obj *objPtr, double value)
222 {
223  dTHX;
224  sv_setnv(ForceScalarLvalue(aTHX_ objPtr),value);
225 }
226 
227 void
Tcl_SetIntObj(Tcl_Obj * objPtr,int value)228 Tcl_SetIntObj (Tcl_Obj *objPtr, int value)
229 {
230  dTHX;
231  sv_setiv(ForceScalarLvalue(aTHX_ objPtr),value);
232 }
233 
234 void
Tcl_SetLongObj(Tcl_Obj * objPtr,long value)235 Tcl_SetLongObj (Tcl_Obj *objPtr, long value)
236 {
237  dTHX;
238  sv_setiv(ForceScalarLvalue(aTHX_ objPtr),value);
239 }
240 
241 void
Tcl_SetStringObj(Tcl_Obj * objPtr,CONST char * bytes,int length)242 Tcl_SetStringObj (Tcl_Obj *objPtr, CONST char *bytes, int length)
243 {
244  dTHX;
245  if (length < 0)
246   length = strlen(bytes);
247  objPtr = ForceScalarLvalue(aTHX_ objPtr);
248  sv_setpvn(objPtr, bytes, length);
249  sv_maybe_utf8(objPtr);
250 }
251 
252 int
Tcl_GetLongFromObj(Tcl_Interp * interp,Tcl_Obj * obj,long * longPtr)253 Tcl_GetLongFromObj (Tcl_Interp *interp, Tcl_Obj *obj, long *longPtr)
254 {
255  dTHX;
256  SV *sv = ForceScalar(aTHX_ obj);
257  if (SvIOK(sv) || looks_like_number(sv))
258   *longPtr = SvIV(sv);
259  else
260   {
261    *longPtr = 0;
262    return EXPIRE((interp, "'%s' isn't numeric", SvPVX(sv)));
263   }
264  return TCL_OK;
265 }
266 
267 int
Tcl_GetBooleanFromObj(Tcl_Interp * interp,Tcl_Obj * obj,int * boolPtr)268 Tcl_GetBooleanFromObj (Tcl_Interp *interp, Tcl_Obj *obj, int *boolPtr)
269 {
270  dTHX;
271  SV *sv = ForceScalar(aTHX_ obj);
272  static char *yes[] = {"y", "yes", "true", "on", NULL};
273  static char *no[] =  {"n", "no", "false", "off", NULL};
274  if (SvPOK(sv))
275   {
276    STRLEN na;
277    char *s = SvPV(sv, na);
278    char **p = yes;
279    while (*p)
280     {
281      if (!strcasecmp(s, *p++))
282       {
283        *boolPtr = 1;
284        return TCL_OK;
285       }
286     }
287    p = no;
288    while (*p)
289     {
290      if (!strcasecmp(s, *p++))
291       {
292        *boolPtr = 0;
293        return TCL_OK;
294       }
295     }
296   }
297  *boolPtr = SvTRUE(sv);
298  return TCL_OK;
299 }
300 
301 int
Tcl_GetIntFromObj(Tcl_Interp * interp,Tcl_Obj * obj,int * intPtr)302 Tcl_GetIntFromObj (Tcl_Interp *interp, Tcl_Obj *obj, int *intPtr)
303 {
304  dTHX;
305  SV *sv = ForceScalar(aTHX_ obj);
306  if (SvIOK(sv) || looks_like_number(sv))
307   *intPtr = SvIV(sv);
308  else
309   {
310    *intPtr = 0;
311    return EXPIRE((interp, "'%s' isn't numeric", SvPVX(sv)));
312   }
313  return TCL_OK;
314 }
315 
316 int
Tcl_GetDoubleFromObj(Tcl_Interp * interp,Tcl_Obj * obj,double * doublePtr)317 Tcl_GetDoubleFromObj (Tcl_Interp *interp, Tcl_Obj *obj, double *doublePtr)
318 {
319  dTHX;
320  SV *sv = ForceScalar(aTHX_ obj);
321  if (SvNOK(sv) || looks_like_number(sv))
322   *doublePtr = SvNV(sv);
323  else
324   {
325    *doublePtr = 0;
326    return EXPIRE((interp, "'%s' isn't numeric", SvPVX(sv)));
327   }
328  return TCL_OK;
329 }
330 
331 Tcl_Obj *
Tcl_NewIntObj(int value)332 Tcl_NewIntObj (int value)
333 {
334  dTHX;
335  return newSViv(value);
336 }
337 
338 Tcl_Obj *
Tcl_NewBooleanObj(int value)339 Tcl_NewBooleanObj (int value)
340 {
341  dTHX;
342  return newSViv(value);
343 }
344 
345 Tcl_Obj *
Tcl_NewObj(void)346 Tcl_NewObj(void)
347 {
348  dTHX;
349  return newSVsv(&PL_sv_undef);
350 }
351 
352 Tcl_Obj *
Tcl_NewLongObj(long value)353 Tcl_NewLongObj(long value)
354 {
355  dTHX;
356  return newSViv(value);
357 }
358 
359 Tcl_Obj *
Tcl_NewDoubleObj(double value)360 Tcl_NewDoubleObj(double value)
361 {
362  dTHX;
363  return newSVnv(value);
364 }
365 
366 Tcl_Obj *
Tcl_NewStringObj(CONST char * bytes,int length)367 Tcl_NewStringObj (CONST char *bytes, int length)
368 {
369  dTHX;
370  if (bytes)
371   {
372    SV *sv;
373    if (length < 0)
374     length = strlen(bytes);
375    sv = newSV(length);
376    sv_setpvn(sv,(char *)bytes,length);
377    return sv_maybe_utf8(sv);
378   }
379  else
380   return &PL_sv_undef;
381 }
382 
383 Tcl_Obj *
Tcl_NewListObj(int objc,Tcl_Obj * CONST objv[])384 Tcl_NewListObj (int objc, Tcl_Obj *CONST objv[])
385 {
386  dTHX;
387  AV *av = newAV();
388  if (objc)
389   {
390    while (objc-- > 0)
391     {
392      SV *sv = objv[objc];
393      if (sv)
394       {
395        /* tkConfig.c passes Tcl_NewStringObj() or LangSetDefault()
396           so REFCNT should be ok as-is
397         */
398        if (SvREFCNT(sv) <= 0 || SvTEMP(sv))
399         {
400          LangDebug("%s %d:\n",__FUNCTION__, objc);
401          sv_dump(sv);
402         }
403        av_store(av,objc,sv);
404       }
405     }
406   }
407  return MakeReference((SV *) av);
408 }
409 
410 static char * LangString(SV *sv);
411 
412 #ifdef NEED_FIX_BUGGY_UTF8_STRING
413 /*
414  * Workaround for http://rt.cpan.org/Public/Bug/Display.html?id=41436
415  * This seems to be necessary for perl < 5.10.0 and if a magic
416  * readonly variable like $1 is about to be utf8-ified, and only for
417  * bytes >= 0x80 and <= 0xff
418  *
419  */
420 static char *
FixBuggyUTF8String(SV * sv)421 FixBuggyUTF8String(SV *sv)
422 {
423  dTHX;
424  char* s = NULL;
425  if (SvREADONLY(sv))
426   {
427    STRLEN len = 0;
428    SvREADONLY_off(sv);
429    (void) SvPV_force(sv,len);
430    s = LangString(sv);
431    SvREADONLY_on(sv);
432   }
433  else
434   {
435    LangDebug("%s @ %d not utf8 and cannot be fixed\n",__FUNCTION__,__LINE__);
436    sv_dump(sv);
437    abort();
438   }
439  return s;
440 }
441 #endif
442 
443 static char *
LangString(SV * sv)444 LangString(SV *sv)
445 {
446  dTHX;
447  if (!sv)
448   return "";
449  if (SvGMAGICAL(sv)) mg_get(sv);
450  if (SvPOK(sv))
451   {
452    if (!SvUTF8(sv))
453     sv_utf8_upgrade(sv);
454    return SvPV_nolen(sv);
455   }
456  else
457   {
458    if (SvROK(sv))
459     {
460      SV *rv = SvRV(sv);
461      STRLEN len;
462      char *s;
463      if (SvOBJECT(rv))
464       {
465        /* Special case "our" objects and certainb legacy hacks ... */
466        if (SvTYPE(rv) == SVt_PVHV)
467         {
468          SV **p = hv_fetch((HV *) rv,"_TkValue_",9,0);
469          if (p)
470           {
471            return SvPV_nolen(*p);
472           }
473          else
474           {
475            Lang_CmdInfo *info = WindowCommand(sv, NULL, 0);
476            if (info)
477             {
478              if (info->tkwin)
479               {
480                char *val = Tk_PathName(info->tkwin);
481                hv_store((HV *) rv,"_TkValue_",9,Tcl_NewStringObj(val,strlen(val)),0);
482                return val;
483               }
484              if (info->image)
485               {
486                return SvPV_nolen(info->image);
487               }
488             }
489           }
490         }
491        else if (SvPOK(rv))
492         {
493          /* ref to string is special cased for some reason ? */
494          if (!SvUTF8(rv))
495           sv_utf8_upgrade(rv);
496          return SvPV_nolen(rv);
497         }
498       } /* Object */
499      s = SvPV(sv, len);
500      if (!is_utf8_string(s,len))
501       {
502        sv_setpvn(sv,s,len);
503        sv_utf8_upgrade(sv);
504        s = SvPV(sv, len);
505       }
506      if (!is_utf8_string(s,len))
507       {
508        LangDebug("%s @ %d not utf8 '%.*s'\n",__FUNCTION__,__LINE__,(int) len, s);
509        sv_dump(sv);
510        abort();
511       }
512      return s;
513     } /* reference */
514    else if (SvOK(sv))
515     {
516      if (SvROK(sv) && SvPOK(SvRV(sv)) && !SvUTF8(SvRV(sv)))
517       sv_utf8_upgrade(SvRV(sv));
518      else if (SvPOKp(sv) && !SvPOK(sv))
519       {
520        if (SvTYPE(sv) == SVt_PVLV && !SvUTF8(sv))
521         {
522          /* LVs e.g. substr() don't upgrade */
523          SV *copy = newSVsv(sv);
524          sv_utf8_upgrade(copy);
525          sv_setsv(sv,copy);
526          SvREFCNT_dec(copy);
527         }
528        else
529         {
530          /* Slaven's for magical (tied) SVs with only SvPOKp */
531          SvPOK_on(sv);
532          sv_utf8_upgrade(sv);
533          SvPOK_off(sv);
534          SvPOKp_on(sv);
535         }
536       }
537      return SvPVutf8_nolen(sv);
538     }
539    else
540     return "";
541   }
542 }
543 
544 char *
Tcl_GetStringFromObj(Tcl_Obj * objPtr,int * lengthPtr)545 Tcl_GetStringFromObj (Tcl_Obj *objPtr, int *lengthPtr)
546 {
547  if (objPtr)
548   {
549    dTHX;
550    char *s;
551    if ((SvROK(objPtr) && !SvOBJECT(SvRV(objPtr))
552         && SvTYPE(SvRV(objPtr)) == SVt_PVAV) ||
553        (SvTYPE(objPtr) == SVt_PVAV))
554     objPtr = ForceScalar(aTHX_ objPtr);
555    if (SvPOK(objPtr))
556     {
557      STRLEN len;
558 #ifdef SvUTF8
559      if (!SvUTF8(objPtr))
560       sv_utf8_upgrade(objPtr);
561 #endif
562      s = SvPV(objPtr, len);
563 #ifdef SvUTF8
564      if (!is_utf8_string(s,len))
565       {
566      /*
567        LangDebug("%s @ %d not utf8\n",__FUNCTION__,__LINE__);
568        sv_dump(objPtr);
569      */
570        s = SvPV(objPtr, len);
571        if (!is_utf8_string(s,len))
572         {
573          U8 *p = (U8 *) s;
574 	 U8 *e = p + len;
575 	 while (p < e)
576 	  {
577 	   if (*p > 0x7F)
578 	    *p = '?';
579 	   p++;
580 	  }
581 	}
582       }
583 #endif
584      if (lengthPtr)
585       *lengthPtr = len;
586     }
587    else
588     {
589      s = LangString(objPtr);
590 #ifdef SvUTF8
591 # ifdef NEED_FIX_BUGGY_UTF8_STRING
592      if (!is_utf8_string(s,strlen(s)))
593       {
594        s = FixBuggyUTF8String(objPtr);
595       }
596 # endif
597      if (!is_utf8_string(s,strlen(s)))
598       {
599        LangDebug("%s @ %d not utf8\n",__FUNCTION__,__LINE__);
600        sv_dump(objPtr);
601        abort();
602       }
603 #endif
604      if (lengthPtr)
605       *lengthPtr = strlen(s);
606     }
607    return s;
608   }
609  return NULL;
610 }
611 
612 
613 char *
Tcl_GetString(Tcl_Obj * objPtr)614 Tcl_GetString(Tcl_Obj *objPtr)
615 {
616  return Tcl_GetStringFromObj(objPtr, NULL);
617 }
618 
619 unsigned char *
Tcl_GetByteArrayFromObj(Tcl_Obj * objPtr,int * lengthPtr)620 Tcl_GetByteArrayFromObj(Tcl_Obj * objPtr, int * lengthPtr)
621 {
622  /* FIXME: presumably should downgrade from UTF-8,
623     what frees it ?
624   */
625  /* SRT: Is this correct? */
626  dTHX;
627  sv_utf8_downgrade(objPtr, 0);
628  if (lengthPtr)
629   {
630    return (unsigned char *) SvPV(objPtr, *lengthPtr);
631   }
632  else
633   {
634    return (unsigned char *) SvPV(objPtr, PL_na);
635   }
636 /* return (unsigned char *) Tcl_GetStringFromObj (objPtr, lengthPtr); */
637 }
638 
639 
640 AV *
ForceList(pTHX_ Tcl_Interp * interp,Tcl_Obj * sv)641 ForceList(pTHX_ Tcl_Interp *interp, Tcl_Obj *sv)
642 {
643  if (SvTYPE(sv) == SVt_PVAV)
644   {
645    return (AV *) sv;
646   }
647  else
648   {
649    int object = sv_isobject(sv);
650    if (!object && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)
651     {
652      return (AV *) SvRV(sv);
653     }
654    else
655     {
656      AV *av = newAV();
657      if (!object && (SvIOK(sv) || SvNOK(sv)))
658       {
659        /* Simple case of single number */
660        av_store(av,0,SvREFCNT_inc(sv));
661       }
662      else
663       {
664        /* Parse TCL like strings
665           {} are quotes - and can be nested
666           \ quotes \ itself and whitespace
667 
668           Older Tk used this perl code ...
669           local $_ = shift;
670           my (@arr, $tmp);
671           while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) {
672             if (defined $1) { push @arr, $1 }
673             else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp }
674           }
675        */
676        unsigned char *s = (unsigned char *) Tcl_GetString(sv);
677        int i = 0;
678        while (*s)
679         {
680          unsigned char *base;
681          /* Skip leading whitespace */
682          while (isspace(*s))
683           s++;
684          if (!*s)
685           break;
686          base = s;
687          if (*s == '{')
688           {
689            /* Slurp chars till we find matching '}' */
690            int count = 1;  /* number of open '{' */
691            base = ++s;
692            while (*s)
693             {
694              if (*s == '{')
695               count++;
696              else if (*s == '}' && (--count <= 0))
697               break;
698              s++;
699             }
700            if (*s != '}')
701             {
702              /* Found end of string before closing '}'
703                 TCL would set an error, we will just include the
704                 un-matched opening '{' in the string.
705               */
706              base--;
707             }
708           }
709          else if (*s)
710           {
711            /* Find a "word" */
712            while (*s && !isspace(*s))
713             {
714              if (*s == '\\' && s[1]) /* \ quotes anything except end of string */
715               s++;
716              s++;
717             }
718           }
719          av_store(av,i++,Tcl_NewStringObj(base,(s-base)));
720          if (*s == '}')
721           s++;
722         }
723       }
724      /* Now have an AV populated decide how to return */
725      if (SvREADONLY(sv))
726       {
727        sv_2mortal((SV *) av);
728        return av;
729       }
730      else
731       {
732        SV *ref = MakeReference((SV *) av);
733        SvSetMagicSV(sv,ref);
734        SvREFCNT_dec(ref);
735       }
736      return (AV *) SvRV(sv);
737     }
738   }
739 }
740 
741 void
Tcl_SetListObj(Tcl_Obj * objPtr,int objc,Tcl_Obj * CONST objv[])742 Tcl_SetListObj(Tcl_Obj * objPtr,int objc, Tcl_Obj *CONST objv[])
743 {
744  dTHX;
745  AV *av = ForceList(aTHX_ NULL,objPtr);
746  av_clear(av);
747  while (objc-- > 0)
748   {
749    /* Used by tkListbox.c passing in array from Tcl_ListObjGetEelements()
750     * so we need to increment REFCNT
751     */
752    av_store(av,objc,SvREFCNT_inc(objv[objc]));
753   }
754 }
755 
756 int
Tcl_ListObjAppendElement(Tcl_Interp * interp,Tcl_Obj * listPtr,Tcl_Obj * objPtr)757 Tcl_ListObjAppendElement (Tcl_Interp *interp, Tcl_Obj *listPtr,
758 			    Tcl_Obj *objPtr)
759 {
760  dTHX;
761  AV *av = ForceList(aTHX_ interp,listPtr);
762  if (!objPtr)
763   objPtr = &PL_sv_undef;
764  if (av)
765   {
766    av_push(av, objPtr);
767    return TCL_OK;
768   }
769  return TCL_ERROR;
770 }
771 
772 void
Tcl_AppendElement(interp,string)773 Tcl_AppendElement(interp, string)
774 Tcl_Interp *interp;
775 CONST char *string;
776 {
777  dTHX;
778  Tcl_Obj *result = Tcl_GetObjResult(interp);
779  Tcl_Obj *value  = Tcl_NewStringObj(string,-1);
780  if (1 || SvOK(result))
781   {
782    Tcl_ListObjAppendElement(interp,result,value);
783   }
784  else
785   {
786    SvSetMagicSV(result, value);
787    LangDumpVec(__FUNCTION__,1,&result);
788   }
789 }
790 
791 
792 
793 AV *
MaybeForceList(pTHX_ Tcl_Interp * interp,Tcl_Obj * sv)794 MaybeForceList(pTHX_ Tcl_Interp *interp, Tcl_Obj *sv)
795 {
796  AV *av;
797  int object = sv_isobject(sv);
798  if (!object && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)
799   {
800    return (AV *) SvRV(sv);
801   }
802  else if (!object && (SvIOK(sv) || SvNOK(sv)))
803   {
804    av = newAV();
805    av_store(av,0,SvREFCNT_inc(sv));
806    sv_2mortal((SV *) av);
807    return av;
808   }
809  else if (SvREADONLY(sv))
810   {
811    /* returns mortal list anyway */
812    return ForceList(aTHX_ interp,sv);
813   }
814  else
815   {
816    SvREADONLY_on(sv);
817    av = ForceList(aTHX_ interp,sv);
818    SvREADONLY_off(sv);
819    /* If there was more than one element set the SV */
820    if (av && av_len(av) > 0)
821     {
822      /* AV is mortal - so we want newRV not MakeReference as we need extra REFCNT */
823      SV *ref = newRV((SV *) av);
824      SvSetMagicSV(sv,ref);
825      SvREFCNT_dec(ref);
826     }
827    return av;
828   }
829 }
830 
831 int
Tcl_ListObjGetElements(Tcl_Interp * interp,Tcl_Obj * listPtr,int * objcPtr,Tcl_Obj *** objvPtr)832 Tcl_ListObjGetElements (Tcl_Interp *interp, Tcl_Obj *listPtr,
833 			    int *objcPtr, Tcl_Obj ***objvPtr)
834 {
835  if (listPtr)
836   {
837    dTHX;
838    AV *av = MaybeForceList(aTHX_ interp,listPtr);
839    if (av)
840     {
841      *objcPtr = av_len(av)+1;
842      *objvPtr = AvARRAY(av);
843      return TCL_OK;
844     }
845   }
846  *objcPtr = 0;
847  *objvPtr = NULL;
848  return TCL_OK;
849 }
850 
851 int
Tcl_ListObjIndex(Tcl_Interp * interp,Tcl_Obj * listPtr,int index,Tcl_Obj ** objPtrPtr)852 Tcl_ListObjIndex (Tcl_Interp *interp,  Tcl_Obj *listPtr, int index,
853 			    Tcl_Obj **objPtrPtr)
854 {
855  dTHX;
856  AV *av = ForceList(aTHX_ interp,listPtr);
857  if (av)
858   {
859    SV **svp = av_fetch(av, index, 0);
860    if (svp)
861     {
862      *objPtrPtr = *svp;
863      return TCL_OK;
864     }
865    return EXPIRE((interp, "No element %d",index));
866   }
867  return TCL_ERROR;
868 }
869 
870 int
Tcl_ListObjLength(Tcl_Interp * interp,Tcl_Obj * listPtr,int * intPtr)871 Tcl_ListObjLength (Tcl_Interp *interp, Tcl_Obj *listPtr, int *intPtr)
872 {
873  dTHX;
874  AV *av = ForceList(aTHX_ interp,listPtr);
875  if (av)
876   {
877    *intPtr = av_len(av)+1;
878    return TCL_OK;
879   }
880  return TCL_ERROR;
881 }
882 
883 int
Tcl_ListObjReplace(Tcl_Interp * interp,Tcl_Obj * listPtr,int first,int count,int objc,Tcl_Obj * CONST objv[])884 Tcl_ListObjReplace (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count,
885 			    int objc, Tcl_Obj *CONST objv[])
886 {
887  dTHX;
888  AV *av = ForceList(aTHX_ interp,listPtr);
889  if (av)
890   {
891    int len = av_len(av)+1;
892    int newlen;
893    int i;
894    if (first < 0)
895     first = 0;
896    if (first >= len)
897      first = len;	/* So we'll insert after last element. */
898    if (first + count > len)
899     count = first-len;
900    newlen = len-count+objc;
901    if (newlen > len)
902     {
903      /* Move entries beyond old range up to make room for new */
904      av_extend(av,newlen-1);
905      for (i=len-1; i >= (first+count); i--)
906       {
907        SV **svp = av_fetch(av,i,0);
908        if (svp)
909         av_store(av,i+newlen-len,SvREFCNT_inc(*svp));
910       }
911     }
912    else if (newlen < len)
913     {
914      /* Delete array elements which will be sliced away */
915      for (i=first; i < first+count; i++)
916       {
917        av_delete(av,i,0);
918       }
919      /* Move entries beyond old range down to new location */
920      for (i=first+count; i < len; i++)
921       {
922        SV **svp = av_fetch(av,i,0);
923        if (svp)
924         av_store(av,i+newlen-len,SvREFCNT_inc(*svp));
925       }
926 #ifdef AvFILLp
927      AvFILLp(av) = newlen-1;
928 #else
929      AvFILL(av) = newlen-1;
930 #endif
931     }
932    /* Store new values */
933    for (i=0; i < objc; i++)
934     {
935      /* In tkListbox.c used with incoming objv
936       * so we need to make copies
937       */
938      av_store(av,first+i,newSVsv(objv[i]));
939     }
940    return TCL_OK;
941   }
942  return TCL_ERROR;
943 }
944 
945 int
Tcl_ListObjAppendList(Tcl_Interp * interp,Tcl_Obj * listPtr,Tcl_Obj * elemListPtr)946 Tcl_ListObjAppendList(Tcl_Interp * interp, Tcl_Obj * listPtr,Tcl_Obj * elemListPtr)
947 {
948  dTHX;
949  Tcl_Obj **objv;
950  int objc = 0;
951  int code;
952  AV *av = ForceList(aTHX_ interp,listPtr);
953  if ((code = Tcl_ListObjGetElements(interp,elemListPtr,&objc,&objv)) == TCL_OK)
954   {
955    dTHX;
956    int j = av_len(av)+1;
957    int i;
958    for (i=0; i < objc; i++)
959     {
960      av_store(av,j++,objv[i]);
961     }
962   }
963  return code;
964 }
965 
966 
967 
968 
969 Tcl_Obj *
Tcl_ConcatObj(int objc,Tcl_Obj * CONST objv[])970 Tcl_ConcatObj (int objc, Tcl_Obj *CONST objv[])
971 {
972  /* This is very like Tcl_NewListObj() - but is typically
973     called on a command's objv - which will not have REFCNT
974     set way Tcl_NewListObj() is expecting. So correct that
975     then call Tcl_NewListObj().
976   */
977  dTHX;
978  int i;
979  for (i=0; i < objc; i++)
980   {
981    SV *sv = (SV *)objv[i];
982    if (sv)
983     {
984      SvREFCNT_inc(sv);
985     }
986   }
987  return Tcl_NewListObj (objc, objv);
988 }
989 
990 
991 char *
Tcl_DStringAppendElement(dsPtr,string)992 Tcl_DStringAppendElement(dsPtr, string)
993     Tcl_DString *dsPtr;		/* Structure describing dynamic string. */
994     CONST char *string;		/* String to append.  Must be
995 				 * null-terminated. */
996 {
997     CONST char *s = string;
998     int ch;
999     while ((ch = *s))
1000      {
1001       if (isspace(ch))
1002        break;
1003       s++;
1004      }
1005     if (Tcl_DStringLength(dsPtr)) {
1006 	Tcl_DStringAppend(dsPtr, " ", 1);
1007     }
1008     if (*s) {
1009 	Tcl_DStringAppend(dsPtr, "{", 1);
1010     }
1011     Tcl_DStringAppend(dsPtr, string, -1);
1012     if (*s) {
1013 	Tcl_DStringAppend(dsPtr, "}", 1);
1014     }
1015     return Tcl_DStringValue(dsPtr);
1016 }
1017 
1018 void
Tcl_AppendStringsToObj(Tcl_Obj * obj,...)1019 Tcl_AppendStringsToObj (Tcl_Obj *obj,...)
1020 {
1021  dTHX;
1022  va_list ap;
1023  char *s;
1024  SV *sv = ForceScalar(aTHX_ obj);
1025  va_start(ap,obj);
1026  while ((s = va_arg(ap,char *)))
1027   {
1028    Tcl_AppendToObj(sv,s,-1);
1029   }
1030  va_end(ap);
1031  if (sv != obj && SvROK(obj))
1032   {
1033    SvSetMagicSV(obj,sv);
1034   }
1035 }
1036 
1037 /*
1038  *----------------------------------------------------------------------
1039  *
1040  * Tcl_GetIndexFromObj --
1041  *
1042  *	This procedure looks up an object's value in a table of strings
1043  *	and returns the index of the matching string, if any.
1044  *
1045  * Results:
1046 
1047  *	If the value of objPtr is identical to or a unique abbreviation
1048  *	for one of the entries in objPtr, then the return value is
1049  *	TCL_OK and the index of the matching entry is stored at
1050  *	*indexPtr.  If there isn't a proper match, then TCL_ERROR is
1051  *	returned and an error message is left in interp's result (unless
1052  *	interp is NULL).  The msg argument is used in the error
1053  *	message; for example, if msg has the value "option" then the
1054  *	error message will say something flag 'bad option "foo": must be
1055  *	...'
1056  *
1057  * Side effects:
1058  *	The result of the lookup is cached as the internal rep of
1059  *	objPtr, so that repeated lookups can be done quickly.
1060  *
1061  *----------------------------------------------------------------------
1062  */
1063 
1064 int
Tcl_GetIndexFromObj(interp,objPtr,tablePtr,msg,flags,indexPtr)1065 Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
1066     Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
1067     Tcl_Obj *objPtr;		/* Object containing the string to lookup. */
1068     CONST char **tablePtr;		/* Array of strings to compare against the
1069 				 * value of objPtr; last entry must be NULL
1070 				 * and there must not be duplicate entries. */
1071     CONST char *msg;			/* Identifying word to use in error messages. */
1072     int flags;			/* 0 or TCL_EXACT */
1073     int *indexPtr;		/* Place to store resulting integer index. */
1074 {
1075     int index, length, i, numAbbrev;
1076     CONST char *key, *p1, *p2, **entryPtr;
1077     Tcl_Obj *resultPtr;
1078 
1079     /*
1080      * Lookup the value of the object in the table.  Accept unique
1081      * abbreviations unless TCL_EXACT is set in flags.
1082      */
1083 
1084     key = Tcl_GetStringFromObj(objPtr, &length);
1085     index = -1;
1086     numAbbrev = 0;
1087     for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) {
1088 	for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
1089 	    if (*p1 == 0) {
1090 		index = i;
1091 		goto done;
1092 	    }
1093 	}
1094 	if (*p1 == 0) {
1095 	    /*
1096 	     * The value is an abbreviation for this entry.  Continue
1097 	     * checking other entries to make sure it's unique.  If we
1098 	     * get more than one unique abbreviation, keep searching to
1099 	     * see if there is an exact match, but remember the number
1100 	     * of unique abbreviations and don't allow either.
1101 	     */
1102 
1103 	    numAbbrev++;
1104 	    index = i;
1105 	}
1106     }
1107     if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
1108 	goto error;
1109     }
1110 
1111     done:
1112     *indexPtr = index;
1113     return TCL_OK;
1114 
1115     error:
1116     if (interp != NULL) {
1117 	resultPtr = Tcl_GetObjResult(interp);
1118 	Tcl_AppendStringsToObj(resultPtr,
1119 		(numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
1120 		key, "\": must be ", *tablePtr, (char *) NULL);
1121 	for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) {
1122 	    if (entryPtr[1] == NULL) {
1123 		Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr,
1124 			(char *) NULL);
1125 	    } else {
1126 		Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
1127 			(char *) NULL);
1128 	    }
1129 	}
1130     }
1131     return TCL_ERROR;
1132 }
1133 
1134 void
Tcl_AppendToObj(objPtr,bytes,length)1135 Tcl_AppendToObj(objPtr, bytes, length)
1136     register Tcl_Obj *objPtr;	/* Points to the object to append to. */
1137     CONST char *bytes;		/* Points to the bytes to append to the
1138 				 * object. */
1139     register int length;	/* The number of bytes to append from
1140 				 * "bytes". If < 0, then append all bytes
1141 				 * up to NULL byte. */
1142 {
1143  dTHX;
1144  SV *sv = ForceScalar(aTHX_ objPtr);
1145  int hi;
1146  if (length < 0)
1147   length = strlen(bytes);
1148 #ifdef SvUTF8
1149  if ((hi = has_highbit(bytes,length)))
1150   {
1151    sv_utf8_upgrade(sv);
1152   }
1153  sv_catpvn(sv, bytes, length);
1154  if (hi)
1155   SvUTF8_on(sv);
1156 #else
1157  sv_catpvn(sv, bytes, length);
1158 #endif
1159  if (sv != objPtr && SvROK(objPtr))
1160   SvSetMagicSV(objPtr,sv);
1161 }
1162 
1163 void
Tcl_AppendObjToObj(Tcl_Obj * objPtr,Tcl_Obj * appendObjPtr)1164 Tcl_AppendObjToObj(Tcl_Obj * objPtr,Tcl_Obj * appendObjPtr)
1165 {
1166  int len = 0;
1167  char *s = Tcl_GetStringFromObj(appendObjPtr,&len);
1168  Tcl_AppendToObj(objPtr,s,len);
1169 }
1170 
1171 
1172 
1173 void
Tcl_WrongNumArgs(interp,objc,objv,message)1174 Tcl_WrongNumArgs(interp, objc, objv, message)
1175     Tcl_Interp *interp;			/* Current interpreter. */
1176     int objc;				/* Number of arguments to print
1177 					 * from objv. */
1178     Tcl_Obj *CONST objv[];		/* Initial argument objects, which
1179 					 * should be included in the error
1180 					 * message. */
1181     CONST char *message;		/* Error message to print after the
1182 					 * leading objects in objv. The
1183 					 * message may be NULL. */
1184 {
1185     Tcl_Obj *objPtr;
1186     char **tablePtr;
1187     int i;
1188 
1189     objPtr = Tcl_GetObjResult(interp);
1190     Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
1191     for (i = 0; i < objc; i++) {
1192 	Tcl_AppendStringsToObj(objPtr,
1193 		    Tcl_GetStringFromObj(objv[i], (int *) NULL),
1194 		    (char *) NULL);
1195 	if (i < (objc - 1)) {
1196 	    Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
1197 	}
1198     }
1199     if (message) {
1200       Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);
1201     }
1202     Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
1203 }
1204 
1205 
1206 #define DStringSV(svp) ((*svp) ? (*svp = ForceScalar(aTHX_ *svp)) : (*svp = newSVpv("",0), *svp))
1207 
1208 #undef Tcl_DStringInit
1209 void
Tcl_DStringInit(Tcl_DString * svp)1210 Tcl_DStringInit(Tcl_DString *svp)
1211 {
1212  *svp = NULL;
1213 }
1214 
1215 void
Tcl_DbDStringInit(Tcl_DString * svp,char * file,int line)1216 Tcl_DbDStringInit(Tcl_DString *svp,char *file,int line)
1217 {
1218  Tcl_DStringInit(svp);
1219 }
1220 
1221 void
Tcl_DStringFree(Tcl_DString * svp)1222 Tcl_DStringFree(Tcl_DString *svp)
1223 {
1224  SV *sv;
1225  if ((sv = *svp))
1226   {
1227    dTHX;
1228    SvREFCNT_dec(sv);
1229    *svp = Nullsv;
1230   }
1231 }
1232 
1233 void
Tcl_DStringResult(Tcl_Interp * interp,Tcl_DString * svp)1234 Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *svp)
1235 {
1236  dTHX;
1237  SV *sv = DStringSV(svp);
1238  /* Tcl8.1+ strings are UTF-8 */
1239  Tcl_SetObjResult(interp,sv_maybe_utf8(sv));
1240  /* Now "free" the DString - the SvREFCNT_dec has been done by SetObjResult */
1241  *svp = Nullsv;
1242 }
1243 
1244 char *
Tcl_DStringAppend(Tcl_DString * svp,CONST char * s,int len)1245 Tcl_DStringAppend(Tcl_DString *svp, CONST char *s, int len)
1246 {
1247  dTHX;
1248  SV *sv = DStringSV(svp);
1249  Tcl_AppendToObj(sv,(char *)s,len);
1250  return SvPVX(sv);
1251 }
1252 
1253 int
Tcl_DStringLength(Tcl_DString * svp)1254 Tcl_DStringLength(Tcl_DString *svp)
1255 {
1256  dTHX;
1257  return (int) ((*svp) ? SvCUR(DStringSV(svp)) : 0);
1258 }
1259 
1260 void
Tcl_DStringSetLength(Tcl_DString * svp,int len)1261 Tcl_DStringSetLength(Tcl_DString *svp,int len)
1262 {
1263  dTHX;
1264  SV *sv = DStringSV(svp);
1265  char *s = SvGROW(sv,(Size_t)(len+1));
1266  s[len] = '\0';
1267  SvCUR(sv) = len;
1268 }
1269 
1270 char *
Tcl_DStringValue(Tcl_DString * svp)1271 Tcl_DStringValue(Tcl_DString *svp)
1272 {
1273  dTHX;
1274  SV *sv = DStringSV(svp);
1275  STRLEN len;
1276  return SvPV(sv,len);
1277 }
1278 
1279 void
Tcl_DStringGetResult(Tcl_Interp * interp,Tcl_DString * svp)1280 Tcl_DStringGetResult(Tcl_Interp *interp, Tcl_DString *svp)
1281 {
1282  int len;
1283  char *s = Tcl_GetStringFromObj(Tcl_GetObjResult(interp),&len);
1284  Tcl_DStringAppend(svp,s,len);
1285 }
1286 
1287 /* Now fake Tcl_Obj * internals routines */
1288 
1289 static void
DummyFreeProc(Tcl_Obj * obj)1290 DummyFreeProc(Tcl_Obj *obj)
1291 {
1292 }
1293 
1294 static void
IntUpdateStringProc(Tcl_Obj * obj)1295 IntUpdateStringProc(Tcl_Obj *obj)
1296 {
1297  dTHX;
1298  STRLEN len;
1299  (void) SvPV(obj,len);
1300 }
1301 
1302 static void
IntDupProc(Tcl_Obj * src,Tcl_Obj * dst)1303 IntDupProc(Tcl_Obj *src,Tcl_Obj *dst)
1304 {
1305  dTHX;
1306  SvSetMagicSV(dst,src);
1307  TclObjSetType(dst,TclObjGetType(src));
1308 }
1309 
1310 static int
IntSetFromAnyProc(Tcl_Interp * interp,Tcl_Obj * obj)1311 IntSetFromAnyProc(Tcl_Interp *interp, Tcl_Obj *obj)
1312 {
1313  Tcl_ObjType *typePtr;
1314  Tcl_GetString(obj);
1315  typePtr = TclObjGetType(obj);
1316  if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
1317 	(*typePtr->freeIntRepProc)(obj);
1318   }
1319  TclObjSetType(obj,&tclIntType);
1320  return TCL_OK;
1321 }
1322 
1323 extern Tcl_ObjType   tclDoubleType;
1324 
1325 static int
DoubleSetFromAnyProc(Tcl_Interp * interp,Tcl_Obj * obj)1326 DoubleSetFromAnyProc(Tcl_Interp *interp, Tcl_Obj *obj)
1327 {
1328  Tcl_ObjType *typePtr;
1329  Tcl_GetString(obj);
1330  typePtr = TclObjGetType(obj);
1331  if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
1332 	(*typePtr->freeIntRepProc)(obj);
1333   }
1334  TclObjSetType(obj,&tclDoubleType);
1335  return TCL_OK;
1336 }
1337 
1338 Tcl_ObjType tclIntType = {
1339   "int",
1340   DummyFreeProc,
1341   IntDupProc,
1342   IntUpdateStringProc,
1343   IntSetFromAnyProc
1344 };
1345 
1346 Tcl_ObjType tclDoubleType = {
1347   "double",
1348   DummyFreeProc,
1349   IntDupProc,
1350   IntUpdateStringProc,
1351   DoubleSetFromAnyProc
1352 };
1353 
1354 Tcl_ObjType perlDummyType = {
1355   "scalar",
1356   DummyFreeProc,
1357   IntDupProc,
1358   IntUpdateStringProc,
1359   IntSetFromAnyProc
1360 };
1361 
1362 typedef struct
1363 {
1364  Tcl_ObjType *type;
1365  Tcl_InternalRep internalRep;
1366 } TclObjMagic_t;
1367 
1368 static int
TclObj_get(pTHX_ SV * sv,MAGIC * mg)1369 TclObj_get(pTHX_ SV *sv, MAGIC *mg)
1370 {
1371  TclObjMagic_t *info = (TclObjMagic_t *)SvPVX(mg->mg_obj);
1372  if (info->type == &tclIntType)
1373   {
1374    SvIV_set(sv,info->internalRep.longValue);
1375    SvIOK_on(sv);
1376    LangDebug("%s %p %s %ld'\n",__FUNCTION__,sv,info->type->name,SvIV(sv));
1377    return 0;
1378   }
1379  else if (info->type == &tclDoubleType)
1380   {
1381    SvNV_set(sv,info->internalRep.doubleValue);
1382    SvNOK_on(sv);
1383    LangDebug("%s %p %s %g'\n",__FUNCTION__,sv,info->type->name,SvNV(sv));
1384    return 0;
1385   }
1386  else if (SvROK(sv) || info->type == &perlDummyType)
1387   {
1388    if (!SvPOK(sv) && SvPOKp(sv))
1389     SvPOK_on(sv);
1390 
1391    if (!SvNOK(sv) && SvNOKp(sv))
1392     SvNOK_on(sv);
1393 
1394    if (!SvIOK(sv) && SvIOKp(sv))
1395     SvIOK_on(sv);
1396   }
1397  else
1398   {
1399    Tcl_GetString(sv);
1400    SvPOK_on(sv);
1401 #if 0
1402    LangDebug("%s %p %s '%s'\n",__FUNCTION__,sv,info->type->name,SvPV_nolen(sv));
1403 #endif
1404   }
1405  return 0;
1406 }
1407 
1408 static int
TclObj_free(pTHX_ SV * sv,MAGIC * mg)1409 TclObj_free(pTHX_ SV *sv, MAGIC *mg)
1410 {
1411  TclObjMagic_t * info;
1412  if (SvTYPE(mg->mg_obj) == SVTYPEMASK)
1413   {
1414    /* Oops!! Our magic info SV has already been sweeped away
1415     * during global destruction.  In this case we might leak
1416     * some the stuff hanging off the Tcl_InternalRep, but there
1417     * are not really much more we can do here.
1418     */
1419    return 0;
1420   }
1421  info = (TclObjMagic_t *)SvPVX(mg->mg_obj);
1422  if (info->type)
1423   {
1424 #ifdef DEBUG_TCLOBJ
1425    LangDebug("%s %p %s\n",__FUNCTION__,sv,info->type->name);
1426 #endif
1427    if (info->type->freeIntRepProc != NULL)
1428     {
1429      /* We _use_ MAGIC chain to locate interal rep so
1430       * re-link mg for duration of callback
1431       */
1432      MAGIC *save = SvMAGIC(sv);
1433      SvMAGIC(sv) = mg;
1434      mg->mg_moremagic = NULL;
1435      (*info->type->freeIntRepProc)(sv);
1436      SvMAGIC(sv) = save;
1437     }
1438   }
1439  else
1440   {
1441    /* We can have pretened we are double or int without setting a type */
1442 #if 0
1443    LangDebug("%s %p NULL\n",__FUNCTION__,sv);
1444    sv_dump(sv);
1445 #endif
1446   }
1447  return 0;
1448 }
1449 
1450 static int
TclObj_set(pTHX_ SV * sv,MAGIC * mg)1451 TclObj_set(pTHX_ SV *sv, MAGIC *mg)
1452 {
1453 #ifdef DEBUG_TCLOBJ
1454  TclObjMagic_t *info = (TclObjMagic_t *)SvPVX(mg->mg_obj);
1455  LangDebug("%s %p %s\n",__FUNCTION__,sv,info->type->name);
1456 #endif
1457  sv_unmagic(sv,PERL_MAGIC_ext);  /* sv_unmagic calls free proc */
1458  return 0;
1459 }
1460 
1461 static U32
TclObj_len(pTHX_ SV * sv,MAGIC * mg)1462 TclObj_len(pTHX_ SV *sv, MAGIC *mg)
1463 {
1464 #ifdef DEBUG_TCLOBJ
1465  TclObjMagic_t *info = (TclObjMagic_t *)SvPVX(mg->mg_obj);
1466  LangDebug("%s %s\n",__FUNCTION__,info->type->name);
1467 #endif
1468  return 0;
1469 }
1470 
1471 static int
TclObj_clear(pTHX_ SV * sv,MAGIC * mg)1472 TclObj_clear(pTHX_ SV *sv, MAGIC *mg)
1473 {
1474 #ifdef DEBUG_TCLOBJ
1475  TclObjMagic_t *info = (TclObjMagic_t *)SvPVX(mg->mg_obj);
1476  LangDebug("%s %p %s\n",__FUNCTION__,sv,info->type->name);
1477 #endif
1478  sv_unmagic(sv,PERL_MAGIC_ext);  /* sv_unmagic calls free proc */
1479  return 0;
1480 }
1481 
1482 
1483 MGVTBL TclObj_vtab = {
1484  TclObj_get,
1485  TclObj_set,
1486  NULL, /* TclObj_len, */
1487  TclObj_clear,
1488  TclObj_free
1489 };
1490 
1491 static TclObjMagic_t *
Tcl_ObjMagic(Tcl_Obj * obj,int add)1492 Tcl_ObjMagic(Tcl_Obj *obj,int add)
1493 {
1494  dTHX;
1495  MAGIC *mg = (SvTYPE(obj) >= SVt_PVMG) ? mg_find(obj,PERL_MAGIC_ext) : NULL;
1496  SV *data = NULL;
1497  TclObjMagic_t *iv;
1498  if (mg)
1499   {
1500    if (mg->mg_virtual == &TclObj_vtab)
1501     {
1502      data = mg->mg_obj;
1503     }
1504    else
1505     {
1506      if (add)
1507       {
1508        warn("Wrong kind of '~' magic on %"SVf,obj);
1509        sv_dump(obj);
1510        abort();
1511       }
1512     }
1513   }
1514  else if (add)
1515   {
1516    Tcl_ObjType *type =  TclObjGetType(obj);
1517    int rdonly = SvREADONLY(obj);
1518    data = newSV(sizeof(TclObjMagic_t));
1519    Zero(SvPVX(data),sizeof(TclObjMagic_t),char);
1520    if (rdonly)
1521     SvREADONLY_off(obj);
1522    sv_upgrade(obj,SVt_PVMG);
1523    sv_magic(obj,data,PERL_MAGIC_ext,NULL,0);
1524    SvREFCNT_dec(data);
1525    SvRMAGICAL_off(obj);
1526    mg = mg_find(obj,PERL_MAGIC_ext);
1527    if (mg->mg_obj != data)
1528     abort();
1529    mg->mg_virtual = &TclObj_vtab;
1530    mg_magical(obj);
1531    if (rdonly)
1532     SvREADONLY_on(obj);
1533    iv = (TclObjMagic_t *) SvPVX(data);
1534    iv->type = type;
1535    if (iv->type == &tclIntType)
1536     {
1537 #ifdef HAS_SVIV_NOMG
1538      iv->internalRep.longValue = SvIV_nomg(obj);
1539 #else
1540      iv->internalRep.longValue = SvIV(obj);
1541 #endif
1542     }
1543    else if (iv->type == &tclDoubleType)
1544     {
1545 #ifdef HAS_SVNV_NOMG
1546      iv->internalRep.doubleValue = SvNV_nomg(obj);
1547 #else
1548      iv->internalRep.doubleValue = SvNV(obj);
1549 #endif
1550     }
1551    return iv;
1552   }
1553  if (data)
1554   {
1555    TclObjMagic_t *iv = (TclObjMagic_t *) SvPVX(data);
1556    return iv;
1557   }
1558  return NULL;
1559 }
1560 
1561 Tcl_Obj *
Tcl_DuplicateObj(Tcl_Obj * src)1562 Tcl_DuplicateObj(Tcl_Obj *src)
1563 {
1564  dTHX;
1565  /* We get AVs either from SvRV test below, or
1566   * "suspect" ResultAv scheme
1567   */
1568  int object = sv_isobject(src);
1569  if (SvTYPE(src) == SVt_PVAV)
1570   {
1571    abort();
1572   }
1573  else if (!object && SvROK(src) && SvTYPE(SvRV(src)) == SVt_PVAV)
1574   {
1575    AV *av  = (AV *) SvRV(src);
1576    IV max  = av_len(av);
1577    AV *dst = newAV();
1578    int i;
1579    for (i=0; i <= max; i++)
1580     {
1581      /* Do a deep copy and hope there are no loops */
1582      SV **svp = av_fetch(av,i,0);
1583      SV *d    = (svp && *svp) ? Tcl_DuplicateObj(*svp) : &PL_sv_undef;
1584      av_store(dst,i,d);
1585     }
1586    return MakeReference((SV *) dst);
1587   }
1588  else
1589   {
1590    SV *dup = newSVsv(src);
1591    TclObjMagic_t *m = Tcl_ObjMagic(src,0);
1592    if (m && m->type)
1593     {
1594      if (m->type->dupIntRepProc)
1595       {
1596        (*m->type->dupIntRepProc)(src,dup);
1597       }
1598      else
1599       {
1600        TclObjMagic_t *n = Tcl_ObjMagic(dup,1);
1601        n->type = m->type;
1602        n->internalRep = m->internalRep;
1603       }
1604     }
1605    return dup;
1606   }
1607 }
1608 
1609 Tcl_ObjType *
Tcl_GetObjType(CONST char * name)1610 Tcl_GetObjType(CONST char *name)
1611 {
1612  if (strEQ(name,"int"))
1613   return &tclIntType;
1614  if (strEQ(name,"double"))
1615   return &tclDoubleType;
1616  LangDebug("%s wanted %s\n",__FUNCTION__,name);
1617  return &perlDummyType;
1618 }
1619 
1620 static void
NoFreeProc(Tcl_Obj * obj)1621 NoFreeProc(Tcl_Obj *obj)
1622 {
1623  TclObjMagic_t *m = Tcl_ObjMagic(obj,1);
1624  LangDebug("%s %p %s\n",__FUNCTION__,obj,m->type->name);
1625 }
1626 
1627 Tcl_ObjType *
TclObjGetType(Tcl_Obj * obj)1628 TclObjGetType(Tcl_Obj *obj)
1629 {
1630  TclObjMagic_t *m = Tcl_ObjMagic(obj,0);
1631  if (m)
1632   {
1633 #ifdef DEBUG_TCLOBJ
1634    if (!m->type->freeIntRepProc)
1635     m->type->freeIntRepProc = &NoFreeProc;
1636 #endif
1637    return m->type;
1638   }
1639  if (SvNOK(obj))
1640   {
1641    return &tclDoubleType;
1642   }
1643  else if (SvIOK(obj))
1644   {
1645    return &tclIntType;
1646   }
1647  return &perlDummyType;
1648 }
1649 
1650 int
TclObjLength(Tcl_Obj * obj)1651 TclObjLength(Tcl_Obj *obj)
1652 {
1653  dTHX;
1654  STRLEN len;
1655  char *s = SvPV(obj,len);
1656  return len;
1657 }
1658 
1659 void
TclObjSetType(Tcl_Obj * obj,Tcl_ObjType * type)1660 TclObjSetType(Tcl_Obj *obj,Tcl_ObjType *type)
1661 {
1662  TclObjMagic_t *m;
1663  if (type != NULL && !SvOK(obj))
1664   {
1665    if (type)
1666     {
1667      croak("Cannot use undef value for object of type '%s'", type->name);
1668     }
1669    else
1670     {
1671      croak("Cannot assign magic to undef");
1672     }
1673   }
1674  m = Tcl_ObjMagic(obj,1);
1675 #ifdef DEBUG_TCLOBJ
1676  if (m->type)
1677   {
1678    LangDebug("%s %p was %s\n",__FUNCTION__,obj,m->type->name);
1679   }
1680  if (type)
1681   {
1682    LangDebug("%s %p now %s\n",__FUNCTION__,obj,type->name);
1683   }
1684 #endif
1685  m->type = type;
1686 }
1687 
1688 int
Tcl_ConvertToType(Tcl_Interp * interp,Tcl_Obj * objPtr,Tcl_ObjType * typePtr)1689 Tcl_ConvertToType(Tcl_Interp * interp, Tcl_Obj * objPtr,
1690                   Tcl_ObjType * typePtr)
1691 {
1692     if (TclObjGetType(objPtr) == typePtr) {
1693 	return TCL_OK;
1694     }
1695 
1696     /*
1697      * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
1698      * form as appropriate for the target type. This frees the old internal
1699      * representation.
1700      */
1701 
1702     return typePtr->setFromAnyProc(interp, objPtr);
1703 }
1704 
1705 
1706 Tcl_InternalRep *
TclObjInternal(Tcl_Obj * obj)1707 TclObjInternal(Tcl_Obj *obj)
1708 {
1709  TclObjMagic_t *m = Tcl_ObjMagic(obj,1);
1710  return &(m->internalRep);
1711 }
1712 
1713 void
Tcl_RegisterObjType(Tcl_ObjType * type)1714 Tcl_RegisterObjType(Tcl_ObjType *type)
1715 {
1716 }
1717 
1718 
1719 Tcl_Obj *
LangCopyArg(sv)1720 LangCopyArg(sv)
1721 SV *sv;
1722 {
1723  if (sv)
1724   {
1725    dTHX;
1726    MAGIC *mg = (SvTYPE(sv) >= SVt_PVMG) ? mg_find(sv,PERL_MAGIC_ext) : NULL;
1727    if (mg && mg->mg_virtual == &TclObj_vtab)
1728     {
1729      return Tcl_DuplicateObj(sv);
1730     }
1731    if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
1732     {
1733      return LangMakeCallback(sv);
1734     }
1735    sv = newSVsv(sv);
1736   }
1737  return sv;
1738 }
1739 
1740 
1741 
1742 
1743 
1744 
1745