summaryrefslogtreecommitdiffstats
path: root/tests/dcall.test
blob: 41dd777a35cee06d5e7b3127e876322db9bc4a07 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
# Commands covered:  none
#
# This file contains a collection of tests for Tcl_CallWhenDeleted.
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2
namespace import ::tcltest::*

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testdcall [llength [info commands testdcall]]

test dcall-1.1 {deletion callbacks} testdcall {
    lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} testdcall {
    testdcall
} {}
test dcall-1.3 {deletion callbacks} testdcall {
    lsort -increasing [testdcall 20 21 22 -22]
} {20 21}
test dcall-1.4 {deletion callbacks} testdcall {
    lsort -increasing [testdcall 20 21 22 -20]
} {21 22}
test dcall-1.5 {deletion callbacks} testdcall {
    lsort -increasing [testdcall 20 21 22 -21]
} {20 22}
test dcall-1.6 {deletion callbacks} testdcall {
    lsort -increasing [testdcall 20 21 22 -21 -22 -20]
} {}

# cleanup
cleanupTests
return
c index a4e87d5..5c55993 100644 --- a/libtommath/bn_mp_init_set_int.c +++ b/libtommath/bn_mp_init_set_int.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* initialize and set a digit */ @@ -26,6 +26,6 @@ int mp_init_set_int (mp_int * a, unsigned long b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_set_int.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_init_set_int.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_init_size.c b/libtommath/bn_mp_init_size.c index 4433b16..8e01418 100644 --- a/libtommath/bn_mp_init_size.c +++ b/libtommath/bn_mp_init_size.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* init an mp_init for a given size */ @@ -43,6 +43,6 @@ int mp_init_size (mp_int * a, int size) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_size.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_init_size.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_invmod.c b/libtommath/bn_mp_invmod.c index 09e71cd..1546514 100644 --- a/libtommath/bn_mp_invmod.c +++ b/libtommath/bn_mp_invmod.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* hac 14.61, pp608 */ @@ -38,6 +38,6 @@ int mp_invmod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_invmod.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_invmod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_invmod_slow.c b/libtommath/bn_mp_invmod_slow.c index ff9cc96..eedd47d 100644 --- a/libtommath/bn_mp_invmod_slow.c +++ b/libtommath/bn_mp_invmod_slow.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* hac 14.61, pp608 */ @@ -170,6 +170,6 @@ LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_invmod_slow.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_invmod_slow.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_is_square.c b/libtommath/bn_mp_is_square.c index 01f07b3..50c5244 100644 --- a/libtommath/bn_mp_is_square.c +++ b/libtommath/bn_mp_is_square.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* Check if remainders are possible squares - fast exclude non-squares */ @@ -104,6 +104,6 @@ ERR:mp_clear(&t); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_is_square.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_is_square.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_jacobi.c b/libtommath/bn_mp_jacobi.c index cb7713d..91cfeea 100644 --- a/libtommath/bn_mp_jacobi.c +++ b/libtommath/bn_mp_jacobi.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes the jacobi c = (a | n) (or Legendre if n is prime) @@ -100,6 +100,6 @@ LBL_A1:mp_clear (&a1); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_jacobi.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_jacobi.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_karatsuba_mul.c b/libtommath/bn_mp_karatsuba_mul.c index 53187dd..8ea2c27 100644 --- a/libtommath/bn_mp_karatsuba_mul.c +++ b/libtommath/bn_mp_karatsuba_mul.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* c = |a| * |b| using Karatsuba Multiplication using @@ -162,6 +162,6 @@ ERR: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_karatsuba_mul.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_karatsuba_mul.c,v $ */ +/* $Revision: 1.6 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_karatsuba_sqr.c b/libtommath/bn_mp_karatsuba_sqr.c index 7f1f253..a5e198b 100644 --- a/libtommath/bn_mp_karatsuba_sqr.c +++ b/libtommath/bn_mp_karatsuba_sqr.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* Karatsuba squaring, computes b = a*a using three @@ -116,6 +116,6 @@ ERR: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_karatsuba_sqr.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_karatsuba_sqr.c,v $ */ +/* $Revision: 1.6 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_lcm.c b/libtommath/bn_mp_lcm.c index 72a5beb..781eef5 100644 --- a/libtommath/bn_mp_lcm.c +++ b/libtommath/bn_mp_lcm.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes least common multiple as |a*b|/(a, b) */ @@ -55,6 +55,6 @@ LBL_T: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_lcm.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_lcm.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_lshd.c b/libtommath/bn_mp_lshd.c index 84dfa81..f118cf1 100644 --- a/libtommath/bn_mp_lshd.c +++ b/libtommath/bn_mp_lshd.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* shift left a certain amount of digits */ @@ -62,6 +62,6 @@ int mp_lshd (mp_int * a, int b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_lshd.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_lshd.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_mod.c b/libtommath/bn_mp_mod.c index 16d9d76..f5cf8d0 100644 --- a/libtommath/bn_mp_mod.c +++ b/libtommath/bn_mp_mod.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* c = a mod b, 0 <= c < b */ @@ -43,6 +43,6 @@ mp_mod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_mod_2d.c b/libtommath/bn_mp_mod_2d.c index 2ab7e33..e194a06 100644 --- a/libtommath/bn_mp_mod_2d.c +++ b/libtommath/bn_mp_mod_2d.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* calc a value mod 2**b */ @@ -50,6 +50,6 @@ mp_mod_2d (mp_int * a, int b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod_2d.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mod_2d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_mod_d.c b/libtommath/bn_mp_mod_d.c index 91dcbe1..9ca37e6 100644 --- a/libtommath/bn_mp_mod_d.c +++ b/libtommath/bn_mp_mod_d.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ int @@ -22,6 +22,6 @@ mp_mod_d (mp_int * a, mp_digit b, mp_digit * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod_d.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mod_d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_montgomery_calc_normalization.c b/libtommath/bn_mp_montgomery_calc_normalization.c index 59dd8ea..c669fe0 100644 --- a/libtommath/bn_mp_montgomery_calc_normalization.c +++ b/libtommath/bn_mp_montgomery_calc_normalization.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* @@ -54,6 +54,6 @@ int mp_montgomery_calc_normalization (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_calc_normalization.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_calc_normalization.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_montgomery_reduce.c b/libtommath/bn_mp_montgomery_reduce.c index f9305d8..b765090 100644 --- a/libtommath/bn_mp_montgomery_reduce.c +++ b/libtommath/bn_mp_montgomery_reduce.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes xR**-1 == x (mod N) via Montgomery Reduction */ @@ -113,6 +113,6 @@ mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_reduce.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_reduce.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_montgomery_setup.c b/libtommath/bn_mp_montgomery_setup.c index cea6778..261a9fb 100644 --- a/libtommath/bn_mp_montgomery_setup.c +++ b/libtommath/bn_mp_montgomery_setup.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* setups the montgomery reduction stuff */ @@ -54,6 +54,6 @@ mp_montgomery_setup (mp_int * n, mp_digit * rho) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_setup.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_setup.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_mul.c b/libtommath/bn_mp_mul.c index 6506635..8b1117a 100644 --- a/libtommath/bn_mp_mul.c +++ b/libtommath/bn_mp_mul.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* high level multiplication (handles sign) */ @@ -61,6 +61,6 @@ int mp_mul (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mul.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_mul_2.c b/libtommath/bn_mp_mul_2.c index 96d5710..02455fc 100644 --- a/libtommath/bn_mp_mul_2.c +++ b/libtommath/bn_mp_mul_2.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* b = a*2 */ @@ -77,6 +77,6 @@ int mp_mul_2(mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_2.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mul_2.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_mul_2d.c b/libtommath/bn_mp_mul_2d.c index 88fa080..efeff2e 100644 --- a/libtommath/bn_mp_mul_2d.c +++ b/libtommath/bn_mp_mul_2d.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* shift left by a certain bit count */ @@ -80,6 +80,6 @@ int mp_mul_2d (mp_int * a, int b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_2d.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mul_2d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_mul_d.c b/libtommath/bn_mp_mul_d.c index e86d6ab..00f9a89 100644 --- a/libtommath/bn_mp_mul_d.c +++ b/libtommath/bn_mp_mul_d.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* multiply by a digit */ @@ -74,6 +74,6 @@ mp_mul_d (mp_int * a, mp_digit b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_d.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mul_d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_mulmod.c b/libtommath/bn_mp_mulmod.c index d84c555..003ceb9 100644 --- a/libtommath/bn_mp_mulmod.c +++ b/libtommath/bn_mp_mulmod.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* d = a * b (mod c) */ @@ -35,6 +35,6 @@ int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mulmod.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mulmod.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_n_root.c b/libtommath/bn_mp_n_root.c index 734d5ea..0e7bedc 100644 --- a/libtommath/bn_mp_n_root.c +++ b/libtommath/bn_mp_n_root.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* find the n'th root of an integer @@ -127,6 +127,6 @@ LBL_T1:mp_clear (&t1); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_n_root.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_n_root.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_neg.c b/libtommath/bn_mp_neg.c index 17e851a..a7d035a 100644 --- a/libtommath/bn_mp_neg.c +++ b/libtommath/bn_mp_neg.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* b = -a */ @@ -35,6 +35,6 @@ int mp_neg (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_neg.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_neg.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_or.c b/libtommath/bn_mp_or.c index 09df58c..bff4995 100644 --- a/libtommath/bn_mp_or.c +++ b/libtommath/bn_mp_or.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* OR two ints together */ @@ -45,6 +45,6 @@ int mp_or (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_or.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_or.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_prime_fermat.c b/libtommath/bn_mp_prime_fermat.c index f6edf9e..c23d77f 100644 --- a/libtommath/bn_mp_prime_fermat.c +++ b/libtommath/bn_mp_prime_fermat.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* performs one Fermat test. @@ -57,6 +57,6 @@ LBL_T:mp_clear (&t); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_fermat.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_fermat.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_prime_is_divisible.c b/libtommath/bn_mp_prime_is_divisible.c index 897c11b..8e7871c 100644 --- a/libtommath/bn_mp_prime_is_divisible.c +++ b/libtommath/bn_mp_prime_is_divisible.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* determines if an integers is divisible by one @@ -45,6 +45,6 @@ int mp_prime_is_divisible (mp_int * a, int *result) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_is_divisible.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_is_divisible.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_prime_is_prime.c b/libtommath/bn_mp_prime_is_prime.c index 135f1d9..c316d62 100644 --- a/libtommath/bn_mp_prime_is_prime.c +++ b/libtommath/bn_mp_prime_is_prime.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* performs a variable number of rounds of Miller-Rabin @@ -78,6 +78,6 @@ LBL_B:mp_clear (&b); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_is_prime.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_is_prime.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_prime_miller_rabin.c b/libtommath/bn_mp_prime_miller_rabin.c index f2d6c7f..ddf0358 100644 --- a/libtommath/bn_mp_prime_miller_rabin.c +++ b/libtommath/bn_mp_prime_miller_rabin.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* Miller-Rabin test of "a" to the base of "b" as described in @@ -98,6 +98,6 @@ LBL_N1:mp_clear (&n1); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_miller_rabin.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_miller_rabin.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_prime_next_prime.c b/libtommath/bn_mp_prime_next_prime.c index a875260..daf2ec7 100644 --- a/libtommath/bn_mp_prime_next_prime.c +++ b/libtommath/bn_mp_prime_next_prime.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* finds the next prime after the number "a" using "t" trials @@ -165,6 +165,6 @@ LBL_ERR: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_next_prime.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_next_prime.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_prime_rabin_miller_trials.c b/libtommath/bn_mp_prime_rabin_miller_trials.c index 30825a3..248c2fd 100644 --- a/libtommath/bn_mp_prime_rabin_miller_trials.c +++ b/libtommath/bn_mp_prime_rabin_miller_trials.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ @@ -47,6 +47,6 @@ int mp_prime_rabin_miller_trials(int size) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_rabin_miller_trials.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_rabin_miller_trials.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_prime_random_ex.c b/libtommath/bn_mp_prime_random_ex.c index baddd10..07aae4b 100644 --- a/libtommath/bn_mp_prime_random_ex.c +++ b/libtommath/bn_mp_prime_random_ex.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* makes a truly random prime of a given size (bits), @@ -120,6 +120,6 @@ error: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_random_ex.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_random_ex.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_radix_size.c b/libtommath/bn_mp_radix_size.c index cf0a093..1b61e3a 100644 --- a/libtommath/bn_mp_radix_size.c +++ b/libtommath/bn_mp_radix_size.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* returns size of ASCII reprensentation */ @@ -73,6 +73,6 @@ int mp_radix_size (mp_int * a, int radix, int *size) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_radix_size.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_radix_size.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_radix_smap.c b/libtommath/bn_mp_radix_smap.c index 913acad..7d72feb 100644 --- a/libtommath/bn_mp_radix_smap.c +++ b/libtommath/bn_mp_radix_smap.c @@ -12,13 +12,13 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* chars used in radix conversions */ const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_radix_smap.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_radix_smap.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_rand.c b/libtommath/bn_mp_rand.c index 6de7447..af66a67 100644 --- a/libtommath/bn_mp_rand.c +++ b/libtommath/bn_mp_rand.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* makes a pseudo-random int of a given size */ @@ -50,6 +50,6 @@ mp_rand (mp_int * a, int digits) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_rand.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_rand.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_read_radix.c b/libtommath/bn_mp_read_radix.c index 9a6dd9b..91c46c2 100644 --- a/libtommath/bn_mp_read_radix.c +++ b/libtommath/bn_mp_read_radix.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* read a string [ASCII] in a given radix */ @@ -80,6 +80,6 @@ int mp_read_radix (mp_int * a, const char *str, int radix) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_radix.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_read_radix.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_read_signed_bin.c b/libtommath/bn_mp_read_signed_bin.c index ae9e6a8..8da651c 100644 --- a/libtommath/bn_mp_read_signed_bin.c +++ b/libtommath/bn_mp_read_signed_bin.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* read signed bin, big endian, first byte is 0==positive or 1==negative */ @@ -36,6 +36,6 @@ int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_signed_bin.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_read_signed_bin.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_read_unsigned_bin.c b/libtommath/bn_mp_read_unsigned_bin.c index b94265f..1ebba13 100644 --- a/libtommath/bn_mp_read_unsigned_bin.c +++ b/libtommath/bn_mp_read_unsigned_bin.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* reads a unsigned char array, assumes the msb is stored first [big endian] */ @@ -50,6 +50,6 @@ int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_unsigned_bin.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_read_unsigned_bin.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_reduce.c b/libtommath/bn_mp_reduce.c index e4c8842..21d0730 100644 --- a/libtommath/bn_mp_reduce.c +++ b/libtommath/bn_mp_reduce.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* reduces x mod m, assumes 0 < x < m**2, mu is @@ -95,6 +95,6 @@ CLEANUP: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_reduce_2k.c b/libtommath/bn_mp_reduce_2k.c index 0bc9f36..d9620c2 100644 --- a/libtommath/bn_mp_reduce_2k.c +++ b/libtommath/bn_mp_reduce_2k.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* reduces a modulo n where n is of the form 2**p - d */ @@ -56,6 +56,6 @@ ERR: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_reduce_2k_l.c b/libtommath/bn_mp_reduce_2k_l.c index ff50948..f06103d 100644 --- a/libtommath/bn_mp_reduce_2k_l.c +++ b/libtommath/bn_mp_reduce_2k_l.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* reduces a modulo n where n is of the form 2**p - d @@ -57,6 +57,6 @@ ERR: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_l.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_l.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_reduce_2k_setup.c b/libtommath/bn_mp_reduce_2k_setup.c index 2a97cd0..a80e7a2 100644 --- a/libtommath/bn_mp_reduce_2k_setup.c +++ b/libtommath/bn_mp_reduce_2k_setup.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* determines the setup value */ @@ -42,6 +42,6 @@ int mp_reduce_2k_setup(mp_int *a, mp_digit *d) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_setup.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_setup.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_reduce_2k_setup_l.c b/libtommath/bn_mp_reduce_2k_setup_l.c index acff733..7cf002e 100644 --- a/libtommath/bn_mp_reduce_2k_setup_l.c +++ b/libtommath/bn_mp_reduce_2k_setup_l.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* determines the setup value */ @@ -39,6 +39,6 @@ ERR: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_setup_l.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_setup_l.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_reduce_is_2k.c b/libtommath/bn_mp_reduce_is_2k.c index e398e19..7308be7 100644 --- a/libtommath/bn_mp_reduce_is_2k.c +++ b/libtommath/bn_mp_reduce_is_2k.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* determines if mp_reduce_2k can be used */ @@ -47,6 +47,6 @@ int mp_reduce_is_2k(mp_int *a) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_is_2k.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_is_2k.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_reduce_is_2k_l.c b/libtommath/bn_mp_reduce_is_2k_l.c index 82e972d..14a4d21 100644 --- a/libtommath/bn_mp_reduce_is_2k_l.c +++ b/libtommath/bn_mp_reduce_is_2k_l.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* determines if reduce_2k_l can be used */ @@ -39,6 +39,6 @@ int mp_reduce_is_2k_l(mp_int *a) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_is_2k_l.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_is_2k_l.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_reduce_setup.c b/libtommath/bn_mp_reduce_setup.c index 94bd26f..370f20b 100644 --- a/libtommath/bn_mp_reduce_setup.c +++ b/libtommath/bn_mp_reduce_setup.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* pre-calculate the value required for Barrett reduction @@ -29,6 +29,6 @@ int mp_reduce_setup (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_setup.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_setup.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_rshd.c b/libtommath/bn_mp_rshd.c index ebc8d5f..2a693c5 100644 --- a/libtommath/bn_mp_rshd.c +++ b/libtommath/bn_mp_rshd.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* shift right a certain amount of digits */ @@ -67,6 +67,6 @@ void mp_rshd (mp_int * a, int b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_rshd.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_rshd.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_set.c b/libtommath/bn_mp_set.c index 9cb64c7..174adcb 100644 --- a/libtommath/bn_mp_set.c +++ b/libtommath/bn_mp_set.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* set to a digit */ @@ -24,6 +24,6 @@ void mp_set (mp_int * a, mp_digit b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_set.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_set.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_set_int.c b/libtommath/bn_mp_set_int.c index 106c4e2..cf10ea1 100644 --- a/libtommath/bn_mp_set_int.c +++ b/libtommath/bn_mp_set_int.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* set a 32-bit const */ @@ -43,6 +43,6 @@ int mp_set_int (mp_int * a, unsigned long b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_set_int.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_set_int.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_shrink.c b/libtommath/bn_mp_shrink.c index ddd72e3..4b8c5ef 100644 --- a/libtommath/bn_mp_shrink.c +++ b/libtommath/bn_mp_shrink.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* shrink a bignum */ @@ -30,6 +30,6 @@ int mp_shrink (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_shrink.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_shrink.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_signed_bin_size.c b/libtommath/bn_mp_signed_bin_size.c index 97fdb96..6739d19 100644 --- a/libtommath/bn_mp_signed_bin_size.c +++ b/libtommath/bn_mp_signed_bin_size.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* get the size for an signed equivalent */ @@ -22,6 +22,6 @@ int mp_signed_bin_size (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_signed_bin_size.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_signed_bin_size.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_sqr.c b/libtommath/bn_mp_sqr.c index 4e75bdb..868ccbb 100644 --- a/libtommath/bn_mp_sqr.c +++ b/libtommath/bn_mp_sqr.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes b = a*a */ @@ -53,6 +53,6 @@ if (a->used >= KARATSUBA_SQR_CUTOFF) { } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqr.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_sqr.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_sqrmod.c b/libtommath/bn_mp_sqrmod.c index d0f0a79..161cbbb 100644 --- a/libtommath/bn_mp_sqrmod.c +++ b/libtommath/bn_mp_sqrmod.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* c = a * a (mod b) */ @@ -36,6 +36,6 @@ mp_sqrmod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqrmod.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_sqrmod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_sqrt.c b/libtommath/bn_mp_sqrt.c index 086801d..8fd057c 100644 --- a/libtommath/bn_mp_sqrt.c +++ b/libtommath/bn_mp_sqrt.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* this function is less generic than mp_n_root, simpler and faster */ @@ -76,6 +76,6 @@ E2: mp_clear(&t1); #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqrt.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_sqrt.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_sub.c b/libtommath/bn_mp_sub.c index c0e2def..f5015cc 100644 --- a/libtommath/bn_mp_sub.c +++ b/libtommath/bn_mp_sub.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* high level subtraction (handles signs) */ @@ -54,6 +54,6 @@ mp_sub (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sub.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_sub.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_sub_d.c b/libtommath/bn_mp_sub_d.c index d979f35..06cdca6 100644 --- a/libtommath/bn_mp_sub_d.c +++ b/libtommath/bn_mp_sub_d.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* single digit subtraction */ @@ -88,6 +88,6 @@ mp_sub_d (mp_int * a, mp_digit b, mp_int * c) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sub_d.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_sub_d.c,v $ */ +/* $Revision: 1.6 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_submod.c b/libtommath/bn_mp_submod.c index 046e844..869e23c 100644 --- a/libtommath/bn_mp_submod.c +++ b/libtommath/bn_mp_submod.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* d = a - b (mod c) */ @@ -37,6 +37,6 @@ mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_submod.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_submod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_to_signed_bin.c b/libtommath/bn_mp_to_signed_bin.c index 066eb51..9df83ca 100644 --- a/libtommath/bn_mp_to_signed_bin.c +++ b/libtommath/bn_mp_to_signed_bin.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* store in signed [big endian] format */ @@ -28,6 +28,6 @@ int mp_to_signed_bin (mp_int * a, unsigned char *b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_signed_bin.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_to_signed_bin.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_to_signed_bin_n.c b/libtommath/bn_mp_to_signed_bin_n.c index b1df632..677f827 100644 --- a/libtommath/bn_mp_to_signed_bin_n.c +++ b/libtommath/bn_mp_to_signed_bin_n.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* store in signed [big endian] format */ @@ -26,6 +26,6 @@ int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_signed_bin_n.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_to_signed_bin_n.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_to_unsigned_bin.c b/libtommath/bn_mp_to_unsigned_bin.c index d69de35..c137f10 100644 --- a/libtommath/bn_mp_to_unsigned_bin.c +++ b/libtommath/bn_mp_to_unsigned_bin.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* store in unsigned [big endian] format */ @@ -43,6 +43,6 @@ int mp_to_unsigned_bin (mp_int * a, unsigned char *b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_unsigned_bin.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_to_unsigned_bin.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_to_unsigned_bin_n.c b/libtommath/bn_mp_to_unsigned_bin_n.c index 5621960..0dc00c6 100644 --- a/libtommath/bn_mp_to_unsigned_bin_n.c +++ b/libtommath/bn_mp_to_unsigned_bin_n.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* store in unsigned [big endian] format */ @@ -26,6 +26,6 @@ int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_unsigned_bin_n.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_to_unsigned_bin_n.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_toom_mul.c b/libtommath/bn_mp_toom_mul.c index 14d0705..ad5d9e9 100644 --- a/libtommath/bn_mp_toom_mul.c +++ b/libtommath/bn_mp_toom_mul.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* multiplication using the Toom-Cook 3-way algorithm @@ -279,6 +279,6 @@ ERR: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toom_mul.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_toom_mul.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_toom_sqr.c b/libtommath/bn_mp_toom_sqr.c index 14a235a..48880d0 100644 --- a/libtommath/bn_mp_toom_sqr.c +++ b/libtommath/bn_mp_toom_sqr.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* squaring using Toom-Cook 3-way algorithm */ @@ -221,6 +221,6 @@ ERR: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toom_sqr.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_toom_sqr.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_toradix.c b/libtommath/bn_mp_toradix.c index 1bd8819..0adc28d 100644 --- a/libtommath/bn_mp_toradix.c +++ b/libtommath/bn_mp_toradix.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* stores a bignum as a ASCII string in a given radix (2..64) */ @@ -70,6 +70,6 @@ int mp_toradix (mp_int * a, char *str, int radix) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toradix.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_toradix.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_toradix_n.c b/libtommath/bn_mp_toradix_n.c index 39d5101..796ed55 100644 --- a/libtommath/bn_mp_toradix_n.c +++ b/libtommath/bn_mp_toradix_n.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* stores a bignum as a ASCII string in a given radix (2..64) @@ -83,6 +83,6 @@ int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toradix_n.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_toradix_n.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_unsigned_bin_size.c b/libtommath/bn_mp_unsigned_bin_size.c index e79b91a..6dc3bd5 100644 --- a/libtommath/bn_mp_unsigned_bin_size.c +++ b/libtommath/bn_mp_unsigned_bin_size.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* get the size for an unsigned equivalent */ @@ -23,6 +23,6 @@ int mp_unsigned_bin_size (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_unsigned_bin_size.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_unsigned_bin_size.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_xor.c b/libtommath/bn_mp_xor.c index bf40408..59ff2e1 100644 --- a/libtommath/bn_mp_xor.c +++ b/libtommath/bn_mp_xor.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* XOR two ints together */ @@ -46,6 +46,6 @@ mp_xor (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_xor.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_xor.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_mp_zero.c b/libtommath/bn_mp_zero.c index 3cbd933..b0977d4 100644 --- a/libtommath/bn_mp_zero.c +++ b/libtommath/bn_mp_zero.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* set to zero */ @@ -31,6 +31,6 @@ void mp_zero (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_zero.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_zero.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_prime_tab.c b/libtommath/bn_prime_tab.c index 38cb592..bd25247 100644 --- a/libtommath/bn_prime_tab.c +++ b/libtommath/bn_prime_tab.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ const mp_digit ltm_prime_tab[] = { 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, @@ -56,6 +56,6 @@ const mp_digit ltm_prime_tab[] = { }; #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_prime_tab.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_prime_tab.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_reverse.c b/libtommath/bn_reverse.c index 3132f93..ddfa827 100644 --- a/libtommath/bn_reverse.c +++ b/libtommath/bn_reverse.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* reverse an array, used for radix code */ @@ -34,6 +34,6 @@ bn_reverse (unsigned char *s, int len) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_reverse.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_reverse.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_s_mp_add.c b/libtommath/bn_s_mp_add.c index 7023300..f034ae6 100644 --- a/libtommath/bn_s_mp_add.c +++ b/libtommath/bn_s_mp_add.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* low level addition, based on HAC pp.594, Algorithm 14.7 */ @@ -104,6 +104,6 @@ s_mp_add (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_add.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_add.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_s_mp_exptmod.c b/libtommath/bn_s_mp_exptmod.c index 7c6e304..097d894 100644 --- a/libtommath/bn_s_mp_exptmod.c +++ b/libtommath/bn_s_mp_exptmod.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ #ifdef MP_LOW_MEM #define TAB_SIZE 32 @@ -247,6 +247,6 @@ LBL_M: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_exptmod.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_exptmod.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_s_mp_mul_digs.c b/libtommath/bn_s_mp_mul_digs.c index eb99e33..f5bbf39 100644 --- a/libtommath/bn_s_mp_mul_digs.c +++ b/libtommath/bn_s_mp_mul_digs.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* multiplies |a| * |b| and only computes upto digs digits of result @@ -85,6 +85,6 @@ int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_mul_digs.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_mul_digs.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_s_mp_mul_high_digs.c b/libtommath/bn_s_mp_mul_high_digs.c index 2ae9ee1..2b718f2 100644 --- a/libtommath/bn_s_mp_mul_high_digs.c +++ b/libtommath/bn_s_mp_mul_high_digs.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* multiplies |a| * |b| and does not compute the lower digs digits @@ -76,6 +76,6 @@ s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_mul_high_digs.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_mul_high_digs.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_s_mp_sqr.c b/libtommath/bn_s_mp_sqr.c index 0ae2869..d2531c2 100644 --- a/libtommath/bn_s_mp_sqr.c +++ b/libtommath/bn_s_mp_sqr.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */ @@ -79,6 +79,6 @@ int s_mp_sqr (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_sqr.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_sqr.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bn_s_mp_sub.c b/libtommath/bn_s_mp_sub.c index 94375a0..6a60c39 100644 --- a/libtommath/bn_s_mp_sub.c +++ b/libtommath/bn_s_mp_sub.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */ @@ -84,6 +84,6 @@ s_mp_sub (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_sub.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_sub.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/bncore.c b/libtommath/bncore.c index e53fdee..8fb1824 100644 --- a/libtommath/bncore.c +++ b/libtommath/bncore.c @@ -12,7 +12,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* Known optimal configurations @@ -31,6 +31,6 @@ int KARATSUBA_MUL_CUTOFF = 80, /* Min. number of digits before Karatsub TOOM_SQR_CUTOFF = 400; #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bncore.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:11 $ */ +/* $Source: /cvs/libtom/libtommath/bncore.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ diff --git a/libtommath/booker.pl b/libtommath/booker.pl index df8b30d..49f1889 100644 --- a/libtommath/booker.pl +++ b/libtommath/booker.pl @@ -82,7 +82,7 @@ while () { # scan till next end of comment, e.g. skip license while () { $text[$line++] = $_; - last if ($_ =~ /math\.libtomcrypt\.org/); + last if ($_ =~ /math\.libtomcrypt\.com/); } ; } diff --git a/libtommath/demo/demo.c b/libtommath/demo/demo.c index 0555366..bb5eb44 100644 --- a/libtommath/demo/demo.c +++ b/libtommath/demo/demo.c @@ -735,6 +735,6 @@ printf("compare no compare!\n"); exit(EXIT_FAILURE); } return 0; } -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/demo/demo.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2005/09/26 16:32:16 $ */ +/* $Source: /cvs/libtom/libtommath/demo/demo.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2005/06/24 11:32:07 $ */ diff --git a/libtommath/demo/timing.c b/libtommath/demo/timing.c index cf0f39c..d4660a9 100644 --- a/libtommath/demo/timing.c +++ b/libtommath/demo/timing.c @@ -314,6 +314,6 @@ int main(void) return 0; } -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/demo/timing.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2005/09/26 16:32:16 $ */ +/* $Source: /cvs/libtom/libtommath/demo/timing.c,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/etc/2kprime.c b/libtommath/etc/2kprime.c index d8ea97c..c09818f 100644 --- a/libtommath/etc/2kprime.c +++ b/libtommath/etc/2kprime.c @@ -79,6 +79,6 @@ int main(void) -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/2kprime.c,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:16 $ */ +/* $Source: /cvs/libtom/libtommath/etc/2kprime.c,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/etc/drprime.c b/libtommath/etc/drprime.c index eec89ed..e413985 100644 --- a/libtommath/etc/drprime.c +++ b/libtommath/etc/drprime.c @@ -59,6 +59,6 @@ int main(void) } -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/drprime.c,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:16 $ */ +/* $Source: /cvs/libtom/libtommath/etc/drprime.c,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/etc/mersenne.c b/libtommath/etc/mersenne.c index e4891c8..6a6497a 100644 --- a/libtommath/etc/mersenne.c +++ b/libtommath/etc/mersenne.c @@ -139,6 +139,6 @@ main (void) return 0; } -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/mersenne.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:28 $ */ +/* $Source: /cvs/libtom/libtommath/etc/mersenne.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:47 $ */ diff --git a/libtommath/etc/mont.c b/libtommath/etc/mont.c index c6a8e32..393be4c 100644 --- a/libtommath/etc/mont.c +++ b/libtommath/etc/mont.c @@ -45,6 +45,6 @@ int main(void) -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/mont.c,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:16 $ */ +/* $Source: /cvs/libtom/libtommath/etc/mont.c,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/etc/pprime.c b/libtommath/etc/pprime.c index abb3c5a..317e2a0 100644 --- a/libtommath/etc/pprime.c +++ b/libtommath/etc/pprime.c @@ -395,6 +395,6 @@ main (void) return 0; } -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/pprime.c,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2006/12/01 00:08:28 $ */ +/* $Source: /cvs/libtom/libtommath/etc/pprime.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:47 $ */ diff --git a/libtommath/etc/tune.c b/libtommath/etc/tune.c index 3088bdb..d4a502c 100644 --- a/libtommath/etc/tune.c +++ b/libtommath/etc/tune.c @@ -137,6 +137,6 @@ main (void) return 0; } -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/tune.c,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:29 $ */ +/* $Source: /cvs/libtom/libtommath/etc/tune.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:47 $ */ diff --git a/libtommath/logs/index.html b/libtommath/logs/index.html index 2b65a0b..4b68c25 100644 --- a/libtommath/logs/index.html +++ b/libtommath/logs/index.html @@ -22,6 +22,6 @@ -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/logs/index.html,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:16 $ */ +/* $Source: /cvs/libtom/libtommath/logs/index.html,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/makefile.cygwin_dll b/libtommath/makefile.cygwin_dll index dae65ae..85a9b20 100644 --- a/libtommath/makefile.cygwin_dll +++ b/libtommath/makefile.cygwin_dll @@ -50,6 +50,6 @@ test: $(OBJECTS) windll gcc $(CFLAGS) demo/demo.c libtommath.dll.a -Wl,--enable-auto-import -o test -s cd mtest ; $(CC) -O3 -fomit-frame-pointer -funroll-loops mtest.c -o mtest -s -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/makefile.cygwin_dll,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2005/09/26 16:31:57 $ */ +/* $Source: /cvs/libtom/libtommath/makefile.cygwin_dll,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:45 $ */ diff --git a/libtommath/mtest/logtab.h b/libtommath/mtest/logtab.h index 4c8774c..bbefaef 100644 --- a/libtommath/mtest/logtab.h +++ b/libtommath/mtest/logtab.h @@ -19,6 +19,6 @@ const float s_logv_2[] = { }; -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/logtab.h,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:17 $ */ +/* $Source: /cvs/libtom/libtommath/mtest/logtab.h,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/mtest/mpi-config.h b/libtommath/mtest/mpi-config.h index e6ffbc4..6049c25 100644 --- a/libtommath/mtest/mpi-config.h +++ b/libtommath/mtest/mpi-config.h @@ -1,5 +1,5 @@ /* Default configuration for MPI library */ -/* $Id: mpi-config.h,v 1.1.1.2 2005/09/26 16:32:17 kennykb Exp $ */ +/* $Id: mpi-config.h,v 1.2 2005/05/05 14:38:47 tom Exp $ */ #ifndef MPI_CONFIG_H_ #define MPI_CONFIG_H_ @@ -85,6 +85,6 @@ /* crc==3287762869, version==2, Sat Feb 02 06:43:53 2002 */ -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi-config.h,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:17 $ */ +/* $Source: /cvs/libtom/libtommath/mtest/mpi-config.h,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/mtest/mpi-types.h b/libtommath/mtest/mpi-types.h index 96d5967..026de58 100644 --- a/libtommath/mtest/mpi-types.h +++ b/libtommath/mtest/mpi-types.h @@ -15,6 +15,6 @@ typedef int mp_err; #define RADIX (MP_DIGIT_MAX+1) -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi-types.h,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:17 $ */ +/* $Source: /cvs/libtom/libtommath/mtest/mpi-types.h,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/mtest/mpi.c b/libtommath/mtest/mpi.c index 1b6f114..7c712dd 100644 --- a/libtommath/mtest/mpi.c +++ b/libtommath/mtest/mpi.c @@ -6,7 +6,7 @@ Arbitrary precision integer arithmetic library - $Id: mpi.c,v 1.1.1.2 2005/09/26 16:32:17 kennykb Exp $ + $Id: mpi.c,v 1.2 2005/05/05 14:38:47 tom Exp $ */ #include "mpi.h" @@ -3980,6 +3980,6 @@ int s_mp_outlen(int bits, int r) /* HERE THERE BE DRAGONS */ /* crc==4242132123, version==2, Sat Feb 02 06:43:52 2002 */ -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi.c,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:17 $ */ +/* $Source: /cvs/libtom/libtommath/mtest/mpi.c,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/mtest/mpi.h b/libtommath/mtest/mpi.h index 1bd0680..66ae873 100644 --- a/libtommath/mtest/mpi.h +++ b/libtommath/mtest/mpi.h @@ -6,7 +6,7 @@ Arbitrary precision integer arithmetic library - $Id: mpi.h,v 1.1.1.2 2005/09/26 16:32:17 kennykb Exp $ + $Id: mpi.h,v 1.2 2005/05/05 14:38:47 tom Exp $ */ #ifndef _H_MPI_ @@ -226,6 +226,6 @@ const char *mp_strerror(mp_err ec); #endif /* end _H_MPI_ */ -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi.h,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:17 $ */ +/* $Source: /cvs/libtom/libtommath/mtest/mpi.h,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/mtest/mtest.c b/libtommath/mtest/mtest.c index f18dc00..bdfe612 100644 --- a/libtommath/mtest/mtest.c +++ b/libtommath/mtest/mtest.c @@ -303,6 +303,6 @@ int main(void) return 0; } -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mtest.c,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:17 $ */ +/* $Source: /cvs/libtom/libtommath/mtest/mtest.c,v $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/05/05 14:38:47 $ */ diff --git a/libtommath/tommath.h b/libtommath/tommath.h index f9b2d11..3c00b9e 100644 --- a/libtommath/tommath.h +++ b/libtommath/tommath.h @@ -579,6 +579,6 @@ extern const char *mp_s_rmap; #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath.h,v $ */ -/* $Revision: 1.1.1.4 $ */ -/* $Date: 2006/12/01 00:08:12 $ */ +/* $Source: /cvs/libtom/libtommath/tommath.h,v $ */ +/* $Revision: 1.8 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/libtommath/tommath_class.h b/libtommath/tommath_class.h index 29e36fc..166dd80 100644 --- a/libtommath/tommath_class.h +++ b/libtommath/tommath_class.h @@ -994,6 +994,6 @@ #define LTM_LAST #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath_class.h,v $ */ -/* $Revision: 1.1.1.3 $ */ -/* $Date: 2005/09/26 16:32:16 $ */ +/* $Source: /cvs/libtom/libtommath/tommath_class.h,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2005/07/28 11:59:32 $ */ diff --git a/libtommath/tommath_superclass.h b/libtommath/tommath_superclass.h index 6722510..2fdebe6 100644 --- a/libtommath/tommath_superclass.h +++ b/libtommath/tommath_superclass.h @@ -71,6 +71,6 @@ #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath_superclass.h,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:32:16 $ */ +/* $Source: /cvs/libtom/libtommath/tommath_superclass.h,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2005/05/14 13:29:17 $ */ -- cgit v0.12 From 4878f1b6a4409b6a7f2514bddb6b3e5391961906 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Mar 2011 11:51:58 +0000 Subject: Import of libtommath 0.40 --- libtommath/bn_mp_montgomery_setup.c | 2 +- libtommath/changes.txt | 4 ++++ libtommath/etc/drprimes.txt | 11 +++++++---- libtommath/makefile | 7 ++++--- libtommath/makefile.shared | 2 +- 5 files changed, 17 insertions(+), 9 deletions(-) diff --git a/libtommath/bn_mp_montgomery_setup.c b/libtommath/bn_mp_montgomery_setup.c index 261a9fb..f082749 100644 --- a/libtommath/bn_mp_montgomery_setup.c +++ b/libtommath/bn_mp_montgomery_setup.c @@ -48,7 +48,7 @@ mp_montgomery_setup (mp_int * n, mp_digit * rho) #endif /* rho = -1/m mod b */ - *rho = (((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK; + *rho = (unsigned long)(((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK; return MP_OKAY; } diff --git a/libtommath/changes.txt b/libtommath/changes.txt index 9498d36..aaaf69f 100644 --- a/libtommath/changes.txt +++ b/libtommath/changes.txt @@ -1,3 +1,7 @@ +December 24th, 2006 +v0.40 -- Updated makefile to properly support LIBNAME + -- Fixed bug in fast_s_mp_mul_high_digs() which overflowed (line 83), thanks Valgrind! + April 4th, 2006 v0.39 -- Jim Wigginton pointed out my Montgomery examples in figures 6.4 and 6.6 were off by one, k should be 9 not 8 -- Bruce Guenter suggested I use --tag=CC for libtool builds where the compiler may think it's C++. diff --git a/libtommath/etc/drprimes.txt b/libtommath/etc/drprimes.txt index 2c887ea..7c97f67 100644 --- a/libtommath/etc/drprimes.txt +++ b/libtommath/etc/drprimes.txt @@ -1,6 +1,9 @@ -280-bit prime: -p == 1942668892225729070919461906823518906642406839052139521251812409738904285204940164839 +300-bit prime: +p == 2037035976334486086268445688409378161051468393665936250636140449354381298610415201576637819 -532-bit prime: -p == 14059105607947488696282932836518693308967803494693489478439861164411992439598399594747002144074658928593502845729752797260025831423419686528151609940203368691747 +540-bit prime: +p == 3599131035634557106248430806148785487095757694641533306480604458089470064537190296255232548883112685719936728506816716098566612844395439751206810991770626477344739 + +780-bit prime: +p == 6359114106063703798370219984742410466332205126109989319225557147754704702203399726411277962562135973685197744935448875852478791860694279747355800678568677946181447581781401213133886609947027230004277244697462656003655947791725966271167 diff --git a/libtommath/makefile b/libtommath/makefile index e08a888..9f69678 100644 --- a/libtommath/makefile +++ b/libtommath/makefile @@ -3,7 +3,7 @@ #Tom St Denis #version of library -VERSION=0.39 +VERSION=0.40 CFLAGS += -I./ -Wall -W -Wshadow -Wsign-compare @@ -40,12 +40,13 @@ else USER=$(INSTALL_USER) endif -default: libtommath.a - #default files to install ifndef LIBNAME LIBNAME=libtommath.a endif + +default: ${LIBNAME} + HEADERS=tommath.h tommath_class.h tommath_superclass.h #LIBPATH-The directory for libtommath to be installed to. diff --git a/libtommath/makefile.shared b/libtommath/makefile.shared index 8522d44..e230fb8 100644 --- a/libtommath/makefile.shared +++ b/libtommath/makefile.shared @@ -1,7 +1,7 @@ #Makefile for GCC # #Tom St Denis -VERSION=0:39 +VERSION=0:40 CC = libtool --mode=compile --tag=CC gcc -- cgit v0.12 From d5b999af66b8094ad876dd981255d78f295766aa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Mar 2011 11:59:15 +0000 Subject: Import of libtommath 0.41 Import of libtommath 0.41 --- libtommath/bn.ind | 130 +++--- libtommath/bn.pdf | Bin 340921 -> 345714 bytes libtommath/bn.tex | 6 +- libtommath/bn_mp_div_d.c | 11 +- libtommath/changes.txt | 4 + libtommath/libtommath.dsp | 572 ++++++++++++++++++++++++ libtommath/logs/addsub.png | Bin 6253 -> 6254 bytes libtommath/logs/expt.png | Bin 6604 -> 6605 bytes libtommath/logs/invmod.png | Bin 4917 -> 4918 bytes libtommath/logs/mult.png | Bin 6769 -> 6770 bytes libtommath/makefile | 2 +- libtommath/makefile.shared | 2 +- libtommath/pics/expt_state.tif | Bin 87540 -> 87542 bytes libtommath/pics/primality.tif | Bin 85512 -> 85514 bytes libtommath/poster.pdf | Bin 37822 -> 37821 bytes libtommath/pre_gen/mpi.c | 963 +++++++++++++++++++++-------------------- libtommath/tommath.pdf | Bin 1194158 -> 1183099 bytes 17 files changed, 1138 insertions(+), 552 deletions(-) create mode 100644 libtommath/libtommath.dsp diff --git a/libtommath/bn.ind b/libtommath/bn.ind index e5f7d4a..c099b52 100644 --- a/libtommath/bn.ind +++ b/libtommath/bn.ind @@ -1,82 +1,82 @@ \begin{theindex} - \item mp\_add, \hyperpage{29} - \item mp\_add\_d, \hyperpage{52} - \item mp\_and, \hyperpage{29} - \item mp\_clear, \hyperpage{11} - \item mp\_clear\_multi, \hyperpage{12} - \item mp\_cmp, \hyperpage{24} - \item mp\_cmp\_d, \hyperpage{25} + \item mp\_add, \hyperpage{31} + \item mp\_add\_d, \hyperpage{56} + \item mp\_and, \hyperpage{31} + \item mp\_clear, \hyperpage{12} + \item mp\_clear\_multi, \hyperpage{13} + \item mp\_cmp, \hyperpage{25} + \item mp\_cmp\_d, \hyperpage{26} \item mp\_cmp\_mag, \hyperpage{23} - \item mp\_div, \hyperpage{30} - \item mp\_div\_2, \hyperpage{26} - \item mp\_div\_2d, \hyperpage{28} - \item mp\_div\_d, \hyperpage{52} - \item mp\_dr\_reduce, \hyperpage{40} - \item mp\_dr\_setup, \hyperpage{40} - \item MP\_EQ, \hyperpage{22} - \item mp\_error\_to\_string, \hyperpage{10} - \item mp\_expt\_d, \hyperpage{43} - \item mp\_exptmod, \hyperpage{43} - \item mp\_exteuclid, \hyperpage{51} - \item mp\_gcd, \hyperpage{51} + \item mp\_div, \hyperpage{32} + \item mp\_div\_2, \hyperpage{28} + \item mp\_div\_2d, \hyperpage{30} + \item mp\_div\_d, \hyperpage{56} + \item mp\_dr\_reduce, \hyperpage{45} + \item mp\_dr\_setup, \hyperpage{45} + \item MP\_EQ, \hyperpage{23} + \item mp\_error\_to\_string, \hyperpage{9} + \item mp\_expt\_d, \hyperpage{47} + \item mp\_exptmod, \hyperpage{47} + \item mp\_exteuclid, \hyperpage{55} + \item mp\_gcd, \hyperpage{55} \item mp\_get\_int, \hyperpage{20} - \item mp\_grow, \hyperpage{16} - \item MP\_GT, \hyperpage{22} + \item mp\_grow, \hyperpage{17} + \item MP\_GT, \hyperpage{23} \item mp\_init, \hyperpage{11} - \item mp\_init\_copy, \hyperpage{13} - \item mp\_init\_multi, \hyperpage{12} + \item mp\_init\_copy, \hyperpage{14} + \item mp\_init\_multi, \hyperpage{13} \item mp\_init\_set, \hyperpage{21} \item mp\_init\_set\_int, \hyperpage{21} - \item mp\_init\_size, \hyperpage{14} + \item mp\_init\_size, \hyperpage{15} \item mp\_int, \hyperpage{10} - \item mp\_invmod, \hyperpage{52} - \item mp\_jacobi, \hyperpage{52} - \item mp\_lcm, \hyperpage{51} - \item mp\_lshd, \hyperpage{28} - \item MP\_LT, \hyperpage{22} + \item mp\_invmod, \hyperpage{56} + \item mp\_jacobi, \hyperpage{56} + \item mp\_lcm, \hyperpage{56} + \item mp\_lshd, \hyperpage{30} + \item MP\_LT, \hyperpage{23} \item MP\_MEM, \hyperpage{9} - \item mp\_mod, \hyperpage{35} - \item mp\_mod\_d, \hyperpage{52} - \item mp\_montgomery\_calc\_normalization, \hyperpage{38} - \item mp\_montgomery\_reduce, \hyperpage{37} - \item mp\_montgomery\_setup, \hyperpage{37} - \item mp\_mul, \hyperpage{31} - \item mp\_mul\_2, \hyperpage{26} - \item mp\_mul\_2d, \hyperpage{28} - \item mp\_mul\_d, \hyperpage{52} - \item mp\_n\_root, \hyperpage{44} - \item mp\_neg, \hyperpage{29} + \item mp\_mod, \hyperpage{39} + \item mp\_mod\_d, \hyperpage{56} + \item mp\_montgomery\_calc\_normalization, \hyperpage{42} + \item mp\_montgomery\_reduce, \hyperpage{42} + \item mp\_montgomery\_setup, \hyperpage{42} + \item mp\_mul, \hyperpage{33} + \item mp\_mul\_2, \hyperpage{28} + \item mp\_mul\_2d, \hyperpage{29} + \item mp\_mul\_d, \hyperpage{56} + \item mp\_n\_root, \hyperpage{48} + \item mp\_neg, \hyperpage{31, 32} \item MP\_NO, \hyperpage{9} \item MP\_OKAY, \hyperpage{9} - \item mp\_or, \hyperpage{29} - \item mp\_prime\_fermat, \hyperpage{45} - \item mp\_prime\_is\_divisible, \hyperpage{45} - \item mp\_prime\_is\_prime, \hyperpage{46} - \item mp\_prime\_miller\_rabin, \hyperpage{45} - \item mp\_prime\_next\_prime, \hyperpage{46} - \item mp\_prime\_rabin\_miller\_trials, \hyperpage{46} - \item mp\_prime\_random, \hyperpage{47} - \item mp\_prime\_random\_ex, \hyperpage{47} - \item mp\_radix\_size, \hyperpage{49} - \item mp\_read\_radix, \hyperpage{49} - \item mp\_read\_unsigned\_bin, \hyperpage{50} - \item mp\_reduce, \hyperpage{36} - \item mp\_reduce\_2k, \hyperpage{41} - \item mp\_reduce\_2k\_setup, \hyperpage{41} - \item mp\_reduce\_setup, \hyperpage{36} - \item mp\_rshd, \hyperpage{28} + \item mp\_or, \hyperpage{31} + \item mp\_prime\_fermat, \hyperpage{49} + \item mp\_prime\_is\_divisible, \hyperpage{49} + \item mp\_prime\_is\_prime, \hyperpage{51} + \item mp\_prime\_miller\_rabin, \hyperpage{50} + \item mp\_prime\_next\_prime, \hyperpage{51} + \item mp\_prime\_rabin\_miller\_trials, \hyperpage{50} + \item mp\_prime\_random, \hyperpage{51} + \item mp\_prime\_random\_ex, \hyperpage{52} + \item mp\_radix\_size, \hyperpage{53} + \item mp\_read\_radix, \hyperpage{53} + \item mp\_read\_unsigned\_bin, \hyperpage{54} + \item mp\_reduce, \hyperpage{40} + \item mp\_reduce\_2k, \hyperpage{46} + \item mp\_reduce\_2k\_setup, \hyperpage{46} + \item mp\_reduce\_setup, \hyperpage{40} + \item mp\_rshd, \hyperpage{30} \item mp\_set, \hyperpage{19} \item mp\_set\_int, \hyperpage{20} - \item mp\_shrink, \hyperpage{15} - \item mp\_sqr, \hyperpage{33} - \item mp\_sub, \hyperpage{29} - \item mp\_sub\_d, \hyperpage{52} - \item mp\_to\_unsigned\_bin, \hyperpage{50} - \item mp\_toradix, \hyperpage{49} - \item mp\_unsigned\_bin\_size, \hyperpage{50} + \item mp\_shrink, \hyperpage{16} + \item mp\_sqr, \hyperpage{35} + \item mp\_sub, \hyperpage{31} + \item mp\_sub\_d, \hyperpage{56} + \item mp\_to\_unsigned\_bin, \hyperpage{54} + \item mp\_toradix, \hyperpage{53} + \item mp\_unsigned\_bin\_size, \hyperpage{54} \item MP\_VAL, \hyperpage{9} - \item mp\_xor, \hyperpage{29} + \item mp\_xor, \hyperpage{31} \item MP\_YES, \hyperpage{9} \end{theindex} diff --git a/libtommath/bn.pdf b/libtommath/bn.pdf index 392b649..5be7123 100644 Binary files a/libtommath/bn.pdf and b/libtommath/bn.pdf differ diff --git a/libtommath/bn.tex b/libtommath/bn.tex index e8eb994..9017860 100644 --- a/libtommath/bn.tex +++ b/libtommath/bn.tex @@ -1,4 +1,4 @@ -\documentclass[b5paper]{book} +\documentclass[synpaper]{book} \usepackage{hyperref} \usepackage{makeidx} \usepackage{amssymb} @@ -49,8 +49,8 @@ \begin{document} \frontmatter \pagestyle{empty} -\title{LibTomMath User Manual \\ v0.39} -\author{Tom St Denis \\ tomstdenis@iahu.ca} +\title{LibTomMath User Manual \\ v0.41} +\author{Tom St Denis \\ tomstdenis@gmail.com} \maketitle This text, the library and the accompanying textbook are all hereby placed in the public domain. This book has been formatted for B5 [176x250] paper using the \LaTeX{} {\em book} macro package. diff --git a/libtommath/bn_mp_div_d.c b/libtommath/bn_mp_div_d.c index d64b4b5..6a26d4f 100644 --- a/libtommath/bn_mp_div_d.c +++ b/libtommath/bn_mp_div_d.c @@ -19,7 +19,12 @@ static int s_is_power_of_two(mp_digit b, int *p) { int x; - for (x = 1; x < DIGIT_BIT; x++) { + /* fast return if no power of two */ + if ((b==0) || (b & (b-1))) { + return 0; + } + + for (x = 0; x < DIGIT_BIT; x++) { if (b == (((mp_digit)1)< +# Microsoft Developer Studio Generated Build File, Format Version 6.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Static Library" 0x0104 + +CFG=libtommath - Win32 Debug +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "libtommath.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "libtommath.mak" CFG="libtommath - Win32 Debug" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "libtommath - Win32 Release" (based on "Win32 (x86) Static Library") +!MESSAGE "libtommath - Win32 Debug" (based on "Win32 (x86) Static Library") +!MESSAGE + +# Begin Project +# PROP AllowPerConfigDependencies 0 +# PROP Scc_ProjName "libtommath" +# PROP Scc_LocalPath "." +CPP=cl.exe +RSC=rc.exe + +!IF "$(CFG)" == "libtommath - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "Release" +# PROP BASE Intermediate_Dir "Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "Release" +# PROP Intermediate_Dir "Release" +# PROP Target_Dir "" +# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c +# ADD CPP /nologo /W3 /GX /O2 /I "." /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c +# ADD BASE RSC /l 0x409 /d "NDEBUG" +# ADD RSC /l 0x409 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LIB32=link.exe -lib +# ADD BASE LIB32 /nologo +# ADD LIB32 /nologo /out:"Release\tommath.lib" + +!ELSEIF "$(CFG)" == "libtommath - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "Debug" +# PROP BASE Intermediate_Dir "Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "Debug" +# PROP Intermediate_Dir "Debug" +# PROP Target_Dir "" +# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c +# ADD CPP /nologo /W3 /Gm /GX /ZI /Od /I "." /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c +# ADD BASE RSC /l 0x409 /d "_DEBUG" +# ADD RSC /l 0x409 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LIB32=link.exe -lib +# ADD BASE LIB32 /nologo +# ADD LIB32 /nologo /out:"Debug\tommath.lib" + +!ENDIF + +# Begin Target + +# Name "libtommath - Win32 Release" +# Name "libtommath - Win32 Debug" +# Begin Source File + +SOURCE=.\bn_error.c +# End Source File +# Begin Source File + +SOURCE=.\bn_fast_mp_invmod.c +# End Source File +# Begin Source File + +SOURCE=.\bn_fast_mp_montgomery_reduce.c +# End Source File +# Begin Source File + +SOURCE=.\bn_fast_s_mp_mul_digs.c +# End Source File +# Begin Source File + +SOURCE=.\bn_fast_s_mp_mul_high_digs.c +# End Source File +# Begin Source File + +SOURCE=.\bn_fast_s_mp_sqr.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_2expt.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_abs.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_add.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_add_d.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_addmod.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_and.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_clamp.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_clear.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_clear_multi.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_cmp.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_cmp_d.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_cmp_mag.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_cnt_lsb.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_copy.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_count_bits.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_div.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_div_2.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_div_2d.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_div_3.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_div_d.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_dr_is_modulus.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_dr_reduce.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_dr_setup.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_exch.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_expt_d.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_exptmod.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_exptmod_fast.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_exteuclid.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_fread.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_fwrite.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_gcd.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_get_int.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_grow.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_init.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_init_copy.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_init_multi.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_init_set.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_init_set_int.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_init_size.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_invmod.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_invmod_slow.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_is_square.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_jacobi.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_karatsuba_mul.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_karatsuba_sqr.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_lcm.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_lshd.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_mod.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_mod_2d.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_mod_d.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_montgomery_calc_normalization.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_montgomery_reduce.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_montgomery_setup.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_mul.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_mul_2.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_mul_2d.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_mul_d.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_mulmod.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_n_root.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_neg.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_or.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_prime_fermat.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_prime_is_divisible.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_prime_is_prime.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_prime_miller_rabin.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_prime_next_prime.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_prime_rabin_miller_trials.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_prime_random_ex.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_radix_size.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_radix_smap.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_rand.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_read_radix.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_read_signed_bin.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_read_unsigned_bin.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_reduce.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_reduce_2k.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_reduce_2k_l.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_reduce_2k_setup.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_reduce_2k_setup_l.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_reduce_is_2k.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_reduce_is_2k_l.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_reduce_setup.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_rshd.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_set.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_set_int.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_shrink.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_signed_bin_size.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_sqr.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_sqrmod.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_sqrt.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_sub.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_sub_d.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_submod.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_to_signed_bin.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_to_signed_bin_n.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_to_unsigned_bin.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_to_unsigned_bin_n.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_toom_mul.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_toom_sqr.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_toradix.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_toradix_n.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_unsigned_bin_size.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_xor.c +# End Source File +# Begin Source File + +SOURCE=.\bn_mp_zero.c +# End Source File +# Begin Source File + +SOURCE=.\bn_prime_tab.c +# End Source File +# Begin Source File + +SOURCE=.\bn_reverse.c +# End Source File +# Begin Source File + +SOURCE=.\bn_s_mp_add.c +# End Source File +# Begin Source File + +SOURCE=.\bn_s_mp_exptmod.c +# End Source File +# Begin Source File + +SOURCE=.\bn_s_mp_mul_digs.c +# End Source File +# Begin Source File + +SOURCE=.\bn_s_mp_mul_high_digs.c +# End Source File +# Begin Source File + +SOURCE=.\bn_s_mp_sqr.c +# End Source File +# Begin Source File + +SOURCE=.\bn_s_mp_sub.c +# End Source File +# Begin Source File + +SOURCE=.\bncore.c +# End Source File +# Begin Source File + +SOURCE=.\tommath.h +# End Source File +# Begin Source File + +SOURCE=.\tommath_class.h +# End Source File +# Begin Source File + +SOURCE=.\tommath_superclass.h +# End Source File +# End Target +# End Project diff --git a/libtommath/logs/addsub.png b/libtommath/logs/addsub.png index 441c7b2..a5679ac 100644 Binary files a/libtommath/logs/addsub.png and b/libtommath/logs/addsub.png differ diff --git a/libtommath/logs/expt.png b/libtommath/logs/expt.png index d779cc5..9ee8bb7 100644 Binary files a/libtommath/logs/expt.png and b/libtommath/logs/expt.png differ diff --git a/libtommath/logs/invmod.png b/libtommath/logs/invmod.png index 9dcd7d8..0a8a4ad 100644 Binary files a/libtommath/logs/invmod.png and b/libtommath/logs/invmod.png differ diff --git a/libtommath/logs/mult.png b/libtommath/logs/mult.png index d22e8c8..4f7a4ee 100644 Binary files a/libtommath/logs/mult.png and b/libtommath/logs/mult.png differ diff --git a/libtommath/makefile b/libtommath/makefile index 9f69678..3e254d4 100644 --- a/libtommath/makefile +++ b/libtommath/makefile @@ -3,7 +3,7 @@ #Tom St Denis #version of library -VERSION=0.40 +VERSION=0.41 CFLAGS += -I./ -Wall -W -Wshadow -Wsign-compare diff --git a/libtommath/makefile.shared b/libtommath/makefile.shared index e230fb8..f17bbbd 100644 --- a/libtommath/makefile.shared +++ b/libtommath/makefile.shared @@ -1,7 +1,7 @@ #Makefile for GCC # #Tom St Denis -VERSION=0:40 +VERSION=0:41 CC = libtool --mode=compile --tag=CC gcc diff --git a/libtommath/pics/expt_state.tif b/libtommath/pics/expt_state.tif index 0aaee39..cb06e8e 100644 Binary files a/libtommath/pics/expt_state.tif and b/libtommath/pics/expt_state.tif differ diff --git a/libtommath/pics/primality.tif b/libtommath/pics/primality.tif index 83aafe0..76d6be3 100644 Binary files a/libtommath/pics/primality.tif and b/libtommath/pics/primality.tif differ diff --git a/libtommath/poster.pdf b/libtommath/poster.pdf index 1f705cf..f3768d7 100644 Binary files a/libtommath/poster.pdf and b/libtommath/poster.pdf differ diff --git a/libtommath/pre_gen/mpi.c b/libtommath/pre_gen/mpi.c index 62ec029..b7f4d47 100644 --- a/libtommath/pre_gen/mpi.c +++ b/libtommath/pre_gen/mpi.c @@ -13,7 +13,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ static const struct { @@ -43,9 +43,9 @@ char *mp_error_to_string(int code) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_error.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_error.c */ @@ -64,7 +64,7 @@ char *mp_error_to_string(int code) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes the modular inverse via binary extended euclidean algorithm, @@ -195,9 +195,9 @@ LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_fast_mp_invmod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_fast_mp_invmod.c */ @@ -216,7 +216,7 @@ LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL); * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes xR**-1 == x (mod N) via Montgomery Reduction @@ -371,9 +371,9 @@ int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_fast_mp_montgomery_reduce.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_fast_mp_montgomery_reduce.c */ @@ -392,7 +392,7 @@ int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* Fast (comba) multiplier @@ -482,9 +482,9 @@ int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_mul_digs.c,v $ */ +/* $Revision: 1.8 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_fast_s_mp_mul_digs.c */ @@ -503,7 +503,7 @@ int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* this is a modified version of fast_s_mul_digs that only produces @@ -569,7 +569,7 @@ int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) register mp_digit *tmpc; tmpc = c->dp + digs; - for (ix = digs; ix <= pa; ix++) { + for (ix = digs; ix < pa; ix++) { /* now extract the previous digit [below the carry] */ *tmpc++ = W[ix]; } @@ -584,9 +584,9 @@ int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_mul_high_digs.c,v $ */ +/* $Revision: 1.6 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_fast_s_mp_mul_high_digs.c */ @@ -605,7 +605,7 @@ int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* the jist of squaring... @@ -702,9 +702,9 @@ int fast_s_mp_sqr (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_sqr.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_fast_s_mp_sqr.c */ @@ -723,7 +723,7 @@ int fast_s_mp_sqr (mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes a = 2**b @@ -754,9 +754,9 @@ mp_2expt (mp_int * a, int b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_2expt.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_2expt.c */ @@ -775,7 +775,7 @@ mp_2expt (mp_int * a, int b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* b = |a| @@ -801,9 +801,9 @@ mp_abs (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_abs.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_abs.c */ @@ -822,7 +822,7 @@ mp_abs (mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* high level addition (handles signs) */ @@ -858,9 +858,9 @@ int mp_add (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_add.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_add.c */ @@ -879,7 +879,7 @@ int mp_add (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* single digit addition */ @@ -974,9 +974,9 @@ mp_add_d (mp_int * a, mp_digit b, mp_int * c) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_add_d.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_add_d.c */ @@ -995,7 +995,7 @@ mp_add_d (mp_int * a, mp_digit b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* d = a + b (mod c) */ @@ -1019,9 +1019,9 @@ mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_addmod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_addmod.c */ @@ -1040,7 +1040,7 @@ mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* AND two ints together */ @@ -1080,9 +1080,9 @@ mp_and (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_and.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_and.c */ @@ -1101,7 +1101,7 @@ mp_and (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* trim unused digits @@ -1128,9 +1128,9 @@ mp_clamp (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_clamp.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_clamp.c */ @@ -1149,7 +1149,7 @@ mp_clamp (mp_int * a) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* clear one (frees) */ @@ -1176,9 +1176,9 @@ mp_clear (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_clear.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_clear.c */ @@ -1197,7 +1197,7 @@ mp_clear (mp_int * a) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ #include @@ -1214,9 +1214,9 @@ void mp_clear_multi(mp_int *mp, ...) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_clear_multi.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_clear_multi.c */ @@ -1235,7 +1235,7 @@ void mp_clear_multi(mp_int *mp, ...) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* compare two ints (signed)*/ @@ -1261,9 +1261,9 @@ mp_cmp (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_cmp.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_cmp.c */ @@ -1282,7 +1282,7 @@ mp_cmp (mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* compare a digit */ @@ -1309,9 +1309,9 @@ int mp_cmp_d(mp_int * a, mp_digit b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_cmp_d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_cmp_d.c */ @@ -1330,7 +1330,7 @@ int mp_cmp_d(mp_int * a, mp_digit b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* compare maginitude of two ints (unsigned) */ @@ -1368,9 +1368,9 @@ int mp_cmp_mag (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_cmp_mag.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_cmp_mag.c */ @@ -1389,7 +1389,7 @@ int mp_cmp_mag (mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ static const int lnz[16] = { @@ -1425,9 +1425,9 @@ int mp_cnt_lsb(mp_int *a) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_cnt_lsb.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_cnt_lsb.c */ @@ -1446,7 +1446,7 @@ int mp_cnt_lsb(mp_int *a) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* copy, b = a */ @@ -1497,9 +1497,9 @@ mp_copy (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_copy.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_copy.c */ @@ -1518,7 +1518,7 @@ mp_copy (mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* returns the number of bits in an int */ @@ -1546,9 +1546,9 @@ mp_count_bits (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_count_bits.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_count_bits.c */ @@ -1567,7 +1567,7 @@ mp_count_bits (mp_int * a) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ #ifdef BN_MP_DIV_SMALL @@ -1842,9 +1842,9 @@ LBL_Q:mp_clear (&q); #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_div.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_div.c */ @@ -1863,7 +1863,7 @@ LBL_Q:mp_clear (&q); * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* b = a/2 */ @@ -1914,9 +1914,9 @@ int mp_div_2(mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_div_2.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_div_2.c */ @@ -1935,7 +1935,7 @@ int mp_div_2(mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* shift right by a certain bit count (store quotient in c, optional remainder in d) */ @@ -2015,9 +2015,9 @@ int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_div_2d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_div_2d.c */ @@ -2036,7 +2036,7 @@ int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* divide by three (based on routine from MPI and the GMP manual) */ @@ -2098,9 +2098,9 @@ mp_div_3 (mp_int * a, mp_int *c, mp_digit * d) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_div_3.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_div_3.c */ @@ -2119,14 +2119,19 @@ mp_div_3 (mp_int * a, mp_int *c, mp_digit * d) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ static int s_is_power_of_two(mp_digit b, int *p) { int x; - for (x = 1; x < DIGIT_BIT; x++) { + /* fast return if no power of two */ + if ((b==0) || (b & (b-1))) { + return 0; + } + + for (x = 0; x < DIGIT_BIT; x++) { if (b == (((mp_digit)1)< @@ -3514,9 +3519,9 @@ int mp_init_multi(mp_int *mp, ...) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_init_multi.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_init_multi.c */ @@ -3535,7 +3540,7 @@ int mp_init_multi(mp_int *mp, ...) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* initialize and set a digit */ @@ -3550,9 +3555,9 @@ int mp_init_set (mp_int * a, mp_digit b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_init_set.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_init_set.c */ @@ -3571,7 +3576,7 @@ int mp_init_set (mp_int * a, mp_digit b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* initialize and set a digit */ @@ -3585,9 +3590,9 @@ int mp_init_set_int (mp_int * a, unsigned long b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_init_set_int.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_init_set_int.c */ @@ -3606,7 +3611,7 @@ int mp_init_set_int (mp_int * a, unsigned long b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* init an mp_init for a given size */ @@ -3637,9 +3642,9 @@ int mp_init_size (mp_int * a, int size) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_init_size.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_init_size.c */ @@ -3658,7 +3663,7 @@ int mp_init_size (mp_int * a, int size) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* hac 14.61, pp608 */ @@ -3684,9 +3689,9 @@ int mp_invmod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_invmod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_invmod.c */ @@ -3705,7 +3710,7 @@ int mp_invmod (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* hac 14.61, pp608 */ @@ -3863,9 +3868,9 @@ LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_invmod_slow.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_invmod_slow.c */ @@ -3884,7 +3889,7 @@ LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL); * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* Check if remainders are possible squares - fast exclude non-squares */ @@ -3976,9 +3981,9 @@ ERR:mp_clear(&t); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_is_square.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_is_square.c */ @@ -3997,7 +4002,7 @@ ERR:mp_clear(&t); * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes the jacobi c = (a | n) (or Legendre if n is prime) @@ -4085,9 +4090,9 @@ LBL_A1:mp_clear (&a1); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_jacobi.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_jacobi.c */ @@ -4106,7 +4111,7 @@ LBL_A1:mp_clear (&a1); * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* c = |a| * |b| using Karatsuba Multiplication using @@ -4256,9 +4261,9 @@ ERR: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_karatsuba_mul.c,v $ */ +/* $Revision: 1.6 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_karatsuba_mul.c */ @@ -4277,7 +4282,7 @@ ERR: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* Karatsuba squaring, computes b = a*a using three @@ -4381,9 +4386,9 @@ ERR: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_karatsuba_sqr.c,v $ */ +/* $Revision: 1.6 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_karatsuba_sqr.c */ @@ -4402,7 +4407,7 @@ ERR: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes least common multiple as |a*b|/(a, b) */ @@ -4445,9 +4450,9 @@ LBL_T: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_lcm.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_lcm.c */ @@ -4466,7 +4471,7 @@ LBL_T: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* shift left a certain amount of digits */ @@ -4516,9 +4521,9 @@ int mp_lshd (mp_int * a, int b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_lshd.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_lshd.c */ @@ -4537,7 +4542,7 @@ int mp_lshd (mp_int * a, int b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* c = a mod b, 0 <= c < b */ @@ -4568,9 +4573,9 @@ mp_mod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_mod.c */ @@ -4589,7 +4594,7 @@ mp_mod (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* calc a value mod 2**b */ @@ -4627,9 +4632,9 @@ mp_mod_2d (mp_int * a, int b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mod_2d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_mod_2d.c */ @@ -4648,7 +4653,7 @@ mp_mod_2d (mp_int * a, int b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ int @@ -4658,9 +4663,9 @@ mp_mod_d (mp_int * a, mp_digit b, mp_digit * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mod_d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_mod_d.c */ @@ -4679,7 +4684,7 @@ mp_mod_d (mp_int * a, mp_digit b, mp_digit * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* @@ -4721,9 +4726,9 @@ int mp_montgomery_calc_normalization (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_calc_normalization.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_montgomery_calc_normalization.c */ @@ -4742,7 +4747,7 @@ int mp_montgomery_calc_normalization (mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes xR**-1 == x (mod N) via Montgomery Reduction */ @@ -4843,9 +4848,9 @@ mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_reduce.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_montgomery_reduce.c */ @@ -4864,7 +4869,7 @@ mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* setups the montgomery reduction stuff */ @@ -4900,15 +4905,15 @@ mp_montgomery_setup (mp_int * n, mp_digit * rho) #endif /* rho = -1/m mod b */ - *rho = (((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK; + *rho = (unsigned long)(((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK; return MP_OKAY; } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_setup.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_montgomery_setup.c */ @@ -4927,7 +4932,7 @@ mp_montgomery_setup (mp_int * n, mp_digit * rho) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* high level multiplication (handles sign) */ @@ -4976,9 +4981,9 @@ int mp_mul (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mul.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_mul.c */ @@ -4997,7 +5002,7 @@ int mp_mul (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* b = a*2 */ @@ -5062,9 +5067,9 @@ int mp_mul_2(mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mul_2.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_mul_2.c */ @@ -5083,7 +5088,7 @@ int mp_mul_2(mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* shift left by a certain bit count */ @@ -5151,9 +5156,9 @@ int mp_mul_2d (mp_int * a, int b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mul_2d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_mul_2d.c */ @@ -5172,7 +5177,7 @@ int mp_mul_2d (mp_int * a, int b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* multiply by a digit */ @@ -5234,9 +5239,9 @@ mp_mul_d (mp_int * a, mp_digit b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mul_d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_mul_d.c */ @@ -5255,7 +5260,7 @@ mp_mul_d (mp_int * a, mp_digit b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* d = a * b (mod c) */ @@ -5278,9 +5283,9 @@ int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_mulmod.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_mulmod.c */ @@ -5299,7 +5304,7 @@ int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* find the n'th root of an integer @@ -5414,9 +5419,9 @@ LBL_T1:mp_clear (&t1); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_n_root.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_n_root.c */ @@ -5435,7 +5440,7 @@ LBL_T1:mp_clear (&t1); * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* b = -a */ @@ -5458,9 +5463,9 @@ int mp_neg (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_neg.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_neg.c */ @@ -5479,7 +5484,7 @@ int mp_neg (mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* OR two ints together */ @@ -5512,9 +5517,9 @@ int mp_or (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_or.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_or.c */ @@ -5533,7 +5538,7 @@ int mp_or (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* performs one Fermat test. @@ -5578,9 +5583,9 @@ LBL_T:mp_clear (&t); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_fermat.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_prime_fermat.c */ @@ -5599,7 +5604,7 @@ LBL_T:mp_clear (&t); * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* determines if an integers is divisible by one @@ -5632,9 +5637,9 @@ int mp_prime_is_divisible (mp_int * a, int *result) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_is_divisible.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_prime_is_divisible.c */ @@ -5653,7 +5658,7 @@ int mp_prime_is_divisible (mp_int * a, int *result) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* performs a variable number of rounds of Miller-Rabin @@ -5719,9 +5724,9 @@ LBL_B:mp_clear (&b); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_is_prime.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_prime_is_prime.c */ @@ -5740,7 +5745,7 @@ LBL_B:mp_clear (&b); * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* Miller-Rabin test of "a" to the base of "b" as described in @@ -5826,9 +5831,9 @@ LBL_N1:mp_clear (&n1); } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_miller_rabin.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_prime_miller_rabin.c */ @@ -5847,7 +5852,7 @@ LBL_N1:mp_clear (&n1); * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* finds the next prime after the number "a" using "t" trials @@ -6000,9 +6005,9 @@ LBL_ERR: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_next_prime.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_prime_next_prime.c */ @@ -6021,7 +6026,7 @@ LBL_ERR: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ @@ -6056,9 +6061,9 @@ int mp_prime_rabin_miller_trials(int size) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_rabin_miller_trials.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_prime_rabin_miller_trials.c */ @@ -6077,7 +6082,7 @@ int mp_prime_rabin_miller_trials(int size) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* makes a truly random prime of a given size (bits), @@ -6185,9 +6190,9 @@ error: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_random_ex.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_prime_random_ex.c */ @@ -6206,7 +6211,7 @@ error: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* returns size of ASCII reprensentation */ @@ -6267,9 +6272,9 @@ int mp_radix_size (mp_int * a, int radix, int *size) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_radix_size.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_radix_size.c */ @@ -6288,16 +6293,16 @@ int mp_radix_size (mp_int * a, int radix, int *size) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* chars used in radix conversions */ const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_radix_smap.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_radix_smap.c */ @@ -6316,7 +6321,7 @@ const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* makes a pseudo-random int of a given size */ @@ -6354,9 +6359,9 @@ mp_rand (mp_int * a, int digits) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_rand.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_rand.c */ @@ -6375,7 +6380,7 @@ mp_rand (mp_int * a, int digits) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* read a string [ASCII] in a given radix */ @@ -6443,9 +6448,9 @@ int mp_read_radix (mp_int * a, const char *str, int radix) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_read_radix.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_read_radix.c */ @@ -6464,7 +6469,7 @@ int mp_read_radix (mp_int * a, const char *str, int radix) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* read signed bin, big endian, first byte is 0==positive or 1==negative */ @@ -6488,9 +6493,9 @@ int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_read_signed_bin.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_read_signed_bin.c */ @@ -6509,7 +6514,7 @@ int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* reads a unsigned char array, assumes the msb is stored first [big endian] */ @@ -6547,9 +6552,9 @@ int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_read_unsigned_bin.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_read_unsigned_bin.c */ @@ -6568,7 +6573,7 @@ int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* reduces x mod m, assumes 0 < x < m**2, mu is @@ -6651,9 +6656,9 @@ CLEANUP: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_reduce.c */ @@ -6672,7 +6677,7 @@ CLEANUP: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* reduces a modulo n where n is of the form 2**p - d */ @@ -6716,9 +6721,9 @@ ERR: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_reduce_2k.c */ @@ -6737,7 +6742,7 @@ ERR: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* reduces a modulo n where n is of the form 2**p - d @@ -6782,9 +6787,9 @@ ERR: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_l.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_reduce_2k_l.c */ @@ -6803,7 +6808,7 @@ ERR: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* determines the setup value */ @@ -6833,9 +6838,9 @@ int mp_reduce_2k_setup(mp_int *a, mp_digit *d) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_setup.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_reduce_2k_setup.c */ @@ -6854,7 +6859,7 @@ int mp_reduce_2k_setup(mp_int *a, mp_digit *d) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* determines the setup value */ @@ -6881,9 +6886,9 @@ ERR: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_setup_l.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_reduce_2k_setup_l.c */ @@ -6902,7 +6907,7 @@ ERR: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* determines if mp_reduce_2k can be used */ @@ -6937,9 +6942,9 @@ int mp_reduce_is_2k(mp_int *a) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_is_2k.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_reduce_is_2k.c */ @@ -6958,7 +6963,7 @@ int mp_reduce_is_2k(mp_int *a) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* determines if reduce_2k_l can be used */ @@ -6985,9 +6990,9 @@ int mp_reduce_is_2k_l(mp_int *a) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_is_2k_l.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_reduce_is_2k_l.c */ @@ -7006,7 +7011,7 @@ int mp_reduce_is_2k_l(mp_int *a) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* pre-calculate the value required for Barrett reduction @@ -7023,9 +7028,9 @@ int mp_reduce_setup (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_setup.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_reduce_setup.c */ @@ -7044,7 +7049,7 @@ int mp_reduce_setup (mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* shift right a certain amount of digits */ @@ -7099,9 +7104,9 @@ void mp_rshd (mp_int * a, int b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_rshd.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_rshd.c */ @@ -7120,7 +7125,7 @@ void mp_rshd (mp_int * a, int b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* set to a digit */ @@ -7132,9 +7137,9 @@ void mp_set (mp_int * a, mp_digit b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_set.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_set.c */ @@ -7153,7 +7158,7 @@ void mp_set (mp_int * a, mp_digit b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* set a 32-bit const */ @@ -7184,9 +7189,9 @@ int mp_set_int (mp_int * a, unsigned long b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_set_int.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_set_int.c */ @@ -7205,7 +7210,7 @@ int mp_set_int (mp_int * a, unsigned long b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* shrink a bignum */ @@ -7223,9 +7228,9 @@ int mp_shrink (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_shrink.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_shrink.c */ @@ -7244,7 +7249,7 @@ int mp_shrink (mp_int * a) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* get the size for an signed equivalent */ @@ -7254,9 +7259,9 @@ int mp_signed_bin_size (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_signed_bin_size.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_signed_bin_size.c */ @@ -7275,7 +7280,7 @@ int mp_signed_bin_size (mp_int * a) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* computes b = a*a */ @@ -7316,9 +7321,9 @@ if (a->used >= KARATSUBA_SQR_CUTOFF) { } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_sqr.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_sqr.c */ @@ -7337,7 +7342,7 @@ if (a->used >= KARATSUBA_SQR_CUTOFF) { * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* c = a * a (mod b) */ @@ -7361,9 +7366,9 @@ mp_sqrmod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_sqrmod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_sqrmod.c */ @@ -7382,7 +7387,7 @@ mp_sqrmod (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* this function is less generic than mp_n_root, simpler and faster */ @@ -7446,9 +7451,9 @@ E2: mp_clear(&t1); #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_sqrt.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_sqrt.c */ @@ -7467,7 +7472,7 @@ E2: mp_clear(&t1); * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* high level subtraction (handles signs) */ @@ -7509,9 +7514,9 @@ mp_sub (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_sub.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_sub.c */ @@ -7530,7 +7535,7 @@ mp_sub (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* single digit subtraction */ @@ -7606,9 +7611,9 @@ mp_sub_d (mp_int * a, mp_digit b, mp_int * c) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_sub_d.c,v $ */ +/* $Revision: 1.6 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_sub_d.c */ @@ -7627,7 +7632,7 @@ mp_sub_d (mp_int * a, mp_digit b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* d = a - b (mod c) */ @@ -7652,9 +7657,9 @@ mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_submod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_submod.c */ @@ -7673,7 +7678,7 @@ mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* store in signed [big endian] format */ @@ -7689,9 +7694,9 @@ int mp_to_signed_bin (mp_int * a, unsigned char *b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_to_signed_bin.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_to_signed_bin.c */ @@ -7710,7 +7715,7 @@ int mp_to_signed_bin (mp_int * a, unsigned char *b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* store in signed [big endian] format */ @@ -7724,9 +7729,9 @@ int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_to_signed_bin_n.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_to_signed_bin_n.c */ @@ -7745,7 +7750,7 @@ int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* store in unsigned [big endian] format */ @@ -7776,9 +7781,9 @@ int mp_to_unsigned_bin (mp_int * a, unsigned char *b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_to_unsigned_bin.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_to_unsigned_bin.c */ @@ -7797,7 +7802,7 @@ int mp_to_unsigned_bin (mp_int * a, unsigned char *b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* store in unsigned [big endian] format */ @@ -7811,9 +7816,9 @@ int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_to_unsigned_bin_n.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_to_unsigned_bin_n.c */ @@ -7832,7 +7837,7 @@ int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* multiplication using the Toom-Cook 3-way algorithm @@ -8099,9 +8104,9 @@ ERR: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_toom_mul.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_toom_mul.c */ @@ -8120,7 +8125,7 @@ ERR: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* squaring using Toom-Cook 3-way algorithm */ @@ -8329,9 +8334,9 @@ ERR: #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_toom_sqr.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_toom_sqr.c */ @@ -8350,7 +8355,7 @@ ERR: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* stores a bignum as a ASCII string in a given radix (2..64) */ @@ -8408,9 +8413,9 @@ int mp_toradix (mp_int * a, char *str, int radix) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_toradix.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_toradix.c */ @@ -8429,7 +8434,7 @@ int mp_toradix (mp_int * a, char *str, int radix) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* stores a bignum as a ASCII string in a given radix (2..64) @@ -8500,9 +8505,9 @@ int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_toradix_n.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_toradix_n.c */ @@ -8521,7 +8526,7 @@ int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* get the size for an unsigned equivalent */ @@ -8532,9 +8537,9 @@ int mp_unsigned_bin_size (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_unsigned_bin_size.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_unsigned_bin_size.c */ @@ -8553,7 +8558,7 @@ int mp_unsigned_bin_size (mp_int * a) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* XOR two ints together */ @@ -8587,9 +8592,9 @@ mp_xor (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_xor.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_xor.c */ @@ -8608,7 +8613,7 @@ mp_xor (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* set to zero */ @@ -8627,9 +8632,9 @@ void mp_zero (mp_int * a) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_mp_zero.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_mp_zero.c */ @@ -8648,7 +8653,7 @@ void mp_zero (mp_int * a) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ const mp_digit ltm_prime_tab[] = { 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, @@ -8692,9 +8697,9 @@ const mp_digit ltm_prime_tab[] = { }; #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_prime_tab.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_prime_tab.c */ @@ -8713,7 +8718,7 @@ const mp_digit ltm_prime_tab[] = { * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* reverse an array, used for radix code */ @@ -8735,9 +8740,9 @@ bn_reverse (unsigned char *s, int len) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_reverse.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_reverse.c */ @@ -8756,7 +8761,7 @@ bn_reverse (unsigned char *s, int len) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* low level addition, based on HAC pp.594, Algorithm 14.7 */ @@ -8848,9 +8853,9 @@ s_mp_add (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_add.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_s_mp_add.c */ @@ -8869,7 +8874,7 @@ s_mp_add (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ #ifdef MP_LOW_MEM #define TAB_SIZE 32 @@ -9104,9 +9109,9 @@ LBL_M: } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_exptmod.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_s_mp_exptmod.c */ @@ -9125,7 +9130,7 @@ LBL_M: * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* multiplies |a| * |b| and only computes upto digs digits of result @@ -9198,9 +9203,9 @@ int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_mul_digs.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_s_mp_mul_digs.c */ @@ -9219,7 +9224,7 @@ int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* multiplies |a| * |b| and does not compute the lower digs digits @@ -9283,9 +9288,9 @@ s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_mul_high_digs.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_s_mp_mul_high_digs.c */ @@ -9304,7 +9309,7 @@ s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */ @@ -9371,9 +9376,9 @@ int s_mp_sqr (mp_int * a, mp_int * b) } #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_sqr.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_s_mp_sqr.c */ @@ -9392,7 +9397,7 @@ int s_mp_sqr (mp_int * a, mp_int * b) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */ @@ -9464,9 +9469,9 @@ s_mp_sub (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bn_s_mp_sub.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bn_s_mp_sub.c */ @@ -9485,7 +9490,7 @@ s_mp_sub (mp_int * a, mp_int * b, mp_int * c) * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://libtom.org */ /* Known optimal configurations @@ -9504,9 +9509,9 @@ int KARATSUBA_MUL_CUTOFF = 80, /* Min. number of digits before Karatsub TOOM_SQR_CUTOFF = 400; #endif -/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ -/* $Revision: 1.1.1.5 $ */ -/* $Date: 2006/12/01 00:08:34 $ */ +/* $Source: /cvs/libtom/libtommath/bncore.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/12/28 01:25:13 $ */ /* End: bncore.c */ diff --git a/libtommath/tommath.pdf b/libtommath/tommath.pdf index c9571d8..33994c3 100644 Binary files a/libtommath/tommath.pdf and b/libtommath/tommath.pdf differ -- cgit v0.12 From a3eb84e8cb98e97f4d06ef6d77df7c6c79b3fb45 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Mar 2011 12:08:07 +0000 Subject: Import of tommath 0.42.0 --- libtommath/bn.ind | 156 +- libtommath/bn.pdf | Bin 345714 -> 352808 bytes libtommath/bn.tex | 2 +- libtommath/bn_error.c | 6 +- libtommath/bn_fast_mp_invmod.c | 6 +- libtommath/bn_fast_mp_montgomery_reduce.c | 6 +- libtommath/bn_fast_s_mp_mul_digs.c | 6 +- libtommath/bn_fast_s_mp_mul_high_digs.c | 6 +- libtommath/bn_fast_s_mp_sqr.c | 6 +- libtommath/bn_mp_2expt.c | 6 +- libtommath/bn_mp_abs.c | 6 +- libtommath/bn_mp_add.c | 6 +- libtommath/bn_mp_add_d.c | 6 +- libtommath/bn_mp_addmod.c | 6 +- libtommath/bn_mp_and.c | 6 +- libtommath/bn_mp_clamp.c | 6 +- libtommath/bn_mp_clear.c | 6 +- libtommath/bn_mp_clear_multi.c | 6 +- libtommath/bn_mp_cmp.c | 6 +- libtommath/bn_mp_cmp_d.c | 6 +- libtommath/bn_mp_cmp_mag.c | 6 +- libtommath/bn_mp_cnt_lsb.c | 6 +- libtommath/bn_mp_copy.c | 6 +- libtommath/bn_mp_count_bits.c | 6 +- libtommath/bn_mp_div.c | 6 +- libtommath/bn_mp_div_2.c | 6 +- libtommath/bn_mp_div_2d.c | 6 +- libtommath/bn_mp_div_3.c | 6 +- libtommath/bn_mp_div_d.c | 6 +- libtommath/bn_mp_dr_is_modulus.c | 6 +- libtommath/bn_mp_dr_reduce.c | 6 +- libtommath/bn_mp_dr_setup.c | 6 +- libtommath/bn_mp_exch.c | 6 +- libtommath/bn_mp_expt_d.c | 6 +- libtommath/bn_mp_exptmod.c | 6 +- libtommath/bn_mp_exptmod_fast.c | 6 +- libtommath/bn_mp_exteuclid.c | 6 +- libtommath/bn_mp_fread.c | 6 +- libtommath/bn_mp_fwrite.c | 6 +- libtommath/bn_mp_gcd.c | 6 +- libtommath/bn_mp_get_int.c | 6 +- libtommath/bn_mp_grow.c | 6 +- libtommath/bn_mp_init.c | 6 +- libtommath/bn_mp_init_copy.c | 6 +- libtommath/bn_mp_init_multi.c | 6 +- libtommath/bn_mp_init_set.c | 6 +- libtommath/bn_mp_init_set_int.c | 6 +- libtommath/bn_mp_init_size.c | 6 +- libtommath/bn_mp_invmod.c | 6 +- libtommath/bn_mp_invmod_slow.c | 6 +- libtommath/bn_mp_is_square.c | 6 +- libtommath/bn_mp_jacobi.c | 6 +- libtommath/bn_mp_karatsuba_mul.c | 6 +- libtommath/bn_mp_karatsuba_sqr.c | 6 +- libtommath/bn_mp_lcm.c | 6 +- libtommath/bn_mp_lshd.c | 6 +- libtommath/bn_mp_mod.c | 6 +- libtommath/bn_mp_mod_2d.c | 6 +- libtommath/bn_mp_mod_d.c | 6 +- libtommath/bn_mp_montgomery_calc_normalization.c | 6 +- libtommath/bn_mp_montgomery_reduce.c | 6 +- libtommath/bn_mp_montgomery_setup.c | 6 +- libtommath/bn_mp_mul.c | 6 +- libtommath/bn_mp_mul_2.c | 6 +- libtommath/bn_mp_mul_2d.c | 6 +- libtommath/bn_mp_mul_d.c | 6 +- libtommath/bn_mp_mulmod.c | 6 +- libtommath/bn_mp_n_root.c | 6 +- libtommath/bn_mp_neg.c | 6 +- libtommath/bn_mp_or.c | 6 +- libtommath/bn_mp_prime_fermat.c | 6 +- libtommath/bn_mp_prime_is_divisible.c | 6 +- libtommath/bn_mp_prime_is_prime.c | 6 +- libtommath/bn_mp_prime_miller_rabin.c | 6 +- libtommath/bn_mp_prime_next_prime.c | 8 +- libtommath/bn_mp_prime_rabin_miller_trials.c | 6 +- libtommath/bn_mp_prime_random_ex.c | 6 +- libtommath/bn_mp_radix_size.c | 6 +- libtommath/bn_mp_radix_smap.c | 6 +- libtommath/bn_mp_rand.c | 6 +- libtommath/bn_mp_read_radix.c | 6 +- libtommath/bn_mp_read_signed_bin.c | 6 +- libtommath/bn_mp_read_unsigned_bin.c | 6 +- libtommath/bn_mp_reduce.c | 6 +- libtommath/bn_mp_reduce_2k.c | 6 +- libtommath/bn_mp_reduce_2k_l.c | 6 +- libtommath/bn_mp_reduce_2k_setup.c | 6 +- libtommath/bn_mp_reduce_2k_setup_l.c | 6 +- libtommath/bn_mp_reduce_is_2k.c | 6 +- libtommath/bn_mp_reduce_is_2k_l.c | 6 +- libtommath/bn_mp_reduce_setup.c | 6 +- libtommath/bn_mp_rshd.c | 6 +- libtommath/bn_mp_set.c | 6 +- libtommath/bn_mp_set_int.c | 6 +- libtommath/bn_mp_shrink.c | 17 +- libtommath/bn_mp_signed_bin_size.c | 6 +- libtommath/bn_mp_sqr.c | 6 +- libtommath/bn_mp_sqrmod.c | 6 +- libtommath/bn_mp_sqrt.c | 6 +- libtommath/bn_mp_sub.c | 6 +- libtommath/bn_mp_sub_d.c | 6 +- libtommath/bn_mp_submod.c | 6 +- libtommath/bn_mp_to_signed_bin.c | 6 +- libtommath/bn_mp_to_signed_bin_n.c | 6 +- libtommath/bn_mp_to_unsigned_bin.c | 6 +- libtommath/bn_mp_to_unsigned_bin_n.c | 6 +- libtommath/bn_mp_toom_mul.c | 6 +- libtommath/bn_mp_toom_sqr.c | 6 +- libtommath/bn_mp_toradix.c | 6 +- libtommath/bn_mp_toradix_n.c | 6 +- libtommath/bn_mp_unsigned_bin_size.c | 6 +- libtommath/bn_mp_xor.c | 6 +- libtommath/bn_mp_zero.c | 6 +- libtommath/bn_prime_tab.c | 6 +- libtommath/bn_reverse.c | 6 +- libtommath/bn_s_mp_add.c | 6 +- libtommath/bn_s_mp_exptmod.c | 6 +- libtommath/bn_s_mp_mul_digs.c | 6 +- libtommath/bn_s_mp_mul_high_digs.c | 6 +- libtommath/bn_s_mp_sqr.c | 6 +- libtommath/bn_s_mp_sub.c | 6 +- libtommath/bncore.c | 6 +- libtommath/changes.txt | 6 + libtommath/demo/demo.c | 6 +- libtommath/demo/timing.c | 6 +- libtommath/etc/2kprime.c | 6 +- libtommath/etc/drprime.c | 6 +- libtommath/etc/mersenne.c | 6 +- libtommath/etc/mont.c | 6 +- libtommath/etc/pprime.c | 6 +- libtommath/etc/tune.c | 6 +- libtommath/libtommath_VS2005.sln | 20 + libtommath/libtommath_VS2005.vcproj | 2803 +++++++++++++++++++++ libtommath/libtommath_VS2008.sln | 20 + libtommath/libtommath_VS2008.vcproj | 2805 ++++++++++++++++++++++ libtommath/makefile | 2 +- libtommath/mtest/logtab.h | 6 +- libtommath/mtest/mpi-config.h | 8 +- libtommath/mtest/mpi-types.h | 6 +- libtommath/mtest/mpi.c | 8 +- libtommath/mtest/mpi.h | 8 +- libtommath/mtest/mtest.c | 6 +- libtommath/poster.pdf | Bin 37821 -> 37806 bytes libtommath/pre_gen/mpi.c | 727 +++--- libtommath/tommath.h | 6 +- libtommath/tommath.pdf | Bin 1183099 -> 1332978 bytes libtommath/tommath_class.h | 6 +- libtommath/tommath_superclass.h | 6 +- 148 files changed, 6520 insertions(+), 856 deletions(-) create mode 100755 libtommath/libtommath_VS2005.sln create mode 100755 libtommath/libtommath_VS2005.vcproj create mode 100755 libtommath/libtommath_VS2008.sln create mode 100755 libtommath/libtommath_VS2008.vcproj diff --git a/libtommath/bn.ind b/libtommath/bn.ind index c099b52..3c3d288 100644 --- a/libtommath/bn.ind +++ b/libtommath/bn.ind @@ -1,82 +1,82 @@ \begin{theindex} - \item mp\_add, \hyperpage{31} - \item mp\_add\_d, \hyperpage{56} - \item mp\_and, \hyperpage{31} - \item mp\_clear, \hyperpage{12} - \item mp\_clear\_multi, \hyperpage{13} - \item mp\_cmp, \hyperpage{25} - \item mp\_cmp\_d, \hyperpage{26} - \item mp\_cmp\_mag, \hyperpage{23} - \item mp\_div, \hyperpage{32} - \item mp\_div\_2, \hyperpage{28} - \item mp\_div\_2d, \hyperpage{30} - \item mp\_div\_d, \hyperpage{56} - \item mp\_dr\_reduce, \hyperpage{45} - \item mp\_dr\_setup, \hyperpage{45} - \item MP\_EQ, \hyperpage{23} - \item mp\_error\_to\_string, \hyperpage{9} - \item mp\_expt\_d, \hyperpage{47} - \item mp\_exptmod, \hyperpage{47} - \item mp\_exteuclid, \hyperpage{55} - \item mp\_gcd, \hyperpage{55} - \item mp\_get\_int, \hyperpage{20} - \item mp\_grow, \hyperpage{17} - \item MP\_GT, \hyperpage{23} - \item mp\_init, \hyperpage{11} - \item mp\_init\_copy, \hyperpage{14} - \item mp\_init\_multi, \hyperpage{13} - \item mp\_init\_set, \hyperpage{21} - \item mp\_init\_set\_int, \hyperpage{21} - \item mp\_init\_size, \hyperpage{15} - \item mp\_int, \hyperpage{10} - \item mp\_invmod, \hyperpage{56} - \item mp\_jacobi, \hyperpage{56} - \item mp\_lcm, \hyperpage{56} - \item mp\_lshd, \hyperpage{30} - \item MP\_LT, \hyperpage{23} - \item MP\_MEM, \hyperpage{9} - \item mp\_mod, \hyperpage{39} - \item mp\_mod\_d, \hyperpage{56} - \item mp\_montgomery\_calc\_normalization, \hyperpage{42} - \item mp\_montgomery\_reduce, \hyperpage{42} - \item mp\_montgomery\_setup, \hyperpage{42} - \item mp\_mul, \hyperpage{33} - \item mp\_mul\_2, \hyperpage{28} - \item mp\_mul\_2d, \hyperpage{29} - \item mp\_mul\_d, \hyperpage{56} - \item mp\_n\_root, \hyperpage{48} - \item mp\_neg, \hyperpage{31, 32} - \item MP\_NO, \hyperpage{9} - \item MP\_OKAY, \hyperpage{9} - \item mp\_or, \hyperpage{31} - \item mp\_prime\_fermat, \hyperpage{49} - \item mp\_prime\_is\_divisible, \hyperpage{49} - \item mp\_prime\_is\_prime, \hyperpage{51} - \item mp\_prime\_miller\_rabin, \hyperpage{50} - \item mp\_prime\_next\_prime, \hyperpage{51} - \item mp\_prime\_rabin\_miller\_trials, \hyperpage{50} - \item mp\_prime\_random, \hyperpage{51} - \item mp\_prime\_random\_ex, \hyperpage{52} - \item mp\_radix\_size, \hyperpage{53} - \item mp\_read\_radix, \hyperpage{53} - \item mp\_read\_unsigned\_bin, \hyperpage{54} - \item mp\_reduce, \hyperpage{40} - \item mp\_reduce\_2k, \hyperpage{46} - \item mp\_reduce\_2k\_setup, \hyperpage{46} - \item mp\_reduce\_setup, \hyperpage{40} - \item mp\_rshd, \hyperpage{30} - \item mp\_set, \hyperpage{19} - \item mp\_set\_int, \hyperpage{20} - \item mp\_shrink, \hyperpage{16} - \item mp\_sqr, \hyperpage{35} - \item mp\_sub, \hyperpage{31} - \item mp\_sub\_d, \hyperpage{56} - \item mp\_to\_unsigned\_bin, \hyperpage{54} - \item mp\_toradix, \hyperpage{53} - \item mp\_unsigned\_bin\_size, \hyperpage{54} - \item MP\_VAL, \hyperpage{9} - \item mp\_xor, \hyperpage{31} - \item MP\_YES, \hyperpage{9} + \item mp\_add, \hyperpage{23} + \item mp\_add\_d, \hyperpage{44} + \item mp\_and, \hyperpage{23} + \item mp\_clear, \hyperpage{9} + \item mp\_clear\_multi, \hyperpage{10} + \item mp\_cmp, \hyperpage{19} + \item mp\_cmp\_d, \hyperpage{20} + \item mp\_cmp\_mag, \hyperpage{18} + \item mp\_div, \hyperpage{24} + \item mp\_div\_2, \hyperpage{21} + \item mp\_div\_2d, \hyperpage{22} + \item mp\_div\_d, \hyperpage{44} + \item mp\_dr\_reduce, \hyperpage{33} + \item mp\_dr\_setup, \hyperpage{33} + \item MP\_EQ, \hyperpage{18} + \item mp\_error\_to\_string, \hyperpage{7} + \item mp\_expt\_d, \hyperpage{35} + \item mp\_exptmod, \hyperpage{35} + \item mp\_exteuclid, \hyperpage{43} + \item mp\_gcd, \hyperpage{43} + \item mp\_get\_int, \hyperpage{16} + \item mp\_grow, \hyperpage{13} + \item MP\_GT, \hyperpage{18} + \item mp\_init, \hyperpage{8} + \item mp\_init\_copy, \hyperpage{10} + \item mp\_init\_multi, \hyperpage{10} + \item mp\_init\_set, \hyperpage{17} + \item mp\_init\_set\_int, \hyperpage{17} + \item mp\_init\_size, \hyperpage{11} + \item mp\_int, \hyperpage{8} + \item mp\_invmod, \hyperpage{44} + \item mp\_jacobi, \hyperpage{43} + \item mp\_lcm, \hyperpage{43} + \item mp\_lshd, \hyperpage{23} + \item MP\_LT, \hyperpage{18} + \item MP\_MEM, \hyperpage{7} + \item mp\_mod, \hyperpage{29} + \item mp\_mod\_d, \hyperpage{44} + \item mp\_montgomery\_calc\_normalization, \hyperpage{31} + \item mp\_montgomery\_reduce, \hyperpage{31} + \item mp\_montgomery\_setup, \hyperpage{31} + \item mp\_mul, \hyperpage{25} + \item mp\_mul\_2, \hyperpage{21} + \item mp\_mul\_2d, \hyperpage{22} + \item mp\_mul\_d, \hyperpage{44} + \item mp\_n\_root, \hyperpage{35} + \item mp\_neg, \hyperpage{24} + \item MP\_NO, \hyperpage{7} + \item MP\_OKAY, \hyperpage{7} + \item mp\_or, \hyperpage{23} + \item mp\_prime\_fermat, \hyperpage{37} + \item mp\_prime\_is\_divisible, \hyperpage{37} + \item mp\_prime\_is\_prime, \hyperpage{38} + \item mp\_prime\_miller\_rabin, \hyperpage{37} + \item mp\_prime\_next\_prime, \hyperpage{38} + \item mp\_prime\_rabin\_miller\_trials, \hyperpage{38} + \item mp\_prime\_random, \hyperpage{38} + \item mp\_prime\_random\_ex, \hyperpage{39} + \item mp\_radix\_size, \hyperpage{41} + \item mp\_read\_radix, \hyperpage{41} + \item mp\_read\_unsigned\_bin, \hyperpage{42} + \item mp\_reduce, \hyperpage{30} + \item mp\_reduce\_2k, \hyperpage{34} + \item mp\_reduce\_2k\_setup, \hyperpage{34} + \item mp\_reduce\_setup, \hyperpage{29} + \item mp\_rshd, \hyperpage{23} + \item mp\_set, \hyperpage{15} + \item mp\_set\_int, \hyperpage{16} + \item mp\_shrink, \hyperpage{12} + \item mp\_sqr, \hyperpage{26} + \item mp\_sub, \hyperpage{23} + \item mp\_sub\_d, \hyperpage{44} + \item mp\_to\_unsigned\_bin, \hyperpage{42} + \item mp\_toradix, \hyperpage{41} + \item mp\_unsigned\_bin\_size, \hyperpage{41} + \item MP\_VAL, \hyperpage{7} + \item mp\_xor, \hyperpage{23} + \item MP\_YES, \hyperpage{7} \end{theindex} diff --git a/libtommath/bn.pdf b/libtommath/bn.pdf index 5be7123..078628c 100644 Binary files a/libtommath/bn.pdf and b/libtommath/bn.pdf differ diff --git a/libtommath/bn.tex b/libtommath/bn.tex index 9017860..71b6840 100644 --- a/libtommath/bn.tex +++ b/libtommath/bn.tex @@ -49,7 +49,7 @@ \begin{document} \frontmatter \pagestyle{empty} -\title{LibTomMath User Manual \\ v0.41} +\title{LibTomMath User Manual \\ v0.42.0} \author{Tom St Denis \\ tomstdenis@gmail.com} \maketitle This text, the library and the accompanying textbook are all hereby placed in the public domain. This book has been diff --git a/libtommath/bn_error.c b/libtommath/bn_error.c index b1b7177..250057b 100644 --- a/libtommath/bn_error.c +++ b/libtommath/bn_error.c @@ -42,6 +42,6 @@ char *mp_error_to_string(int code) #endif -/* $Source: /cvs/libtom/libtommath/bn_error.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_fast_mp_invmod.c b/libtommath/bn_fast_mp_invmod.c index ff03dff..948a134 100644 --- a/libtommath/bn_fast_mp_invmod.c +++ b/libtommath/bn_fast_mp_invmod.c @@ -143,6 +143,6 @@ LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL); } #endif -/* $Source: /cvs/libtom/libtommath/bn_fast_mp_invmod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_fast_mp_montgomery_reduce.c b/libtommath/bn_fast_mp_montgomery_reduce.c index b6c0694..1a81689 100644 --- a/libtommath/bn_fast_mp_montgomery_reduce.c +++ b/libtommath/bn_fast_mp_montgomery_reduce.c @@ -167,6 +167,6 @@ int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) } #endif -/* $Source: /cvs/libtom/libtommath/bn_fast_mp_montgomery_reduce.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_fast_s_mp_mul_digs.c b/libtommath/bn_fast_s_mp_mul_digs.c index 91e10d6..04becfd 100644 --- a/libtommath/bn_fast_s_mp_mul_digs.c +++ b/libtommath/bn_fast_s_mp_mul_digs.c @@ -102,6 +102,6 @@ int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_mul_digs.c,v $ */ -/* $Revision: 1.8 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_fast_s_mp_mul_high_digs.c b/libtommath/bn_fast_s_mp_mul_high_digs.c index 5b114d7..98bee37 100644 --- a/libtommath/bn_fast_s_mp_mul_high_digs.c +++ b/libtommath/bn_fast_s_mp_mul_high_digs.c @@ -93,6 +93,6 @@ int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_mul_high_digs.c,v $ */ -/* $Revision: 1.6 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_fast_s_mp_sqr.c b/libtommath/bn_fast_s_mp_sqr.c index 19e92ef..086b52c 100644 --- a/libtommath/bn_fast_s_mp_sqr.c +++ b/libtommath/bn_fast_s_mp_sqr.c @@ -109,6 +109,6 @@ int fast_s_mp_sqr (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_sqr.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_2expt.c b/libtommath/bn_mp_2expt.c index f422ffc..4774aab 100644 --- a/libtommath/bn_mp_2expt.c +++ b/libtommath/bn_mp_2expt.c @@ -43,6 +43,6 @@ mp_2expt (mp_int * a, int b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_2expt.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_abs.c b/libtommath/bn_mp_abs.c index 09dd722..4d1fa44 100644 --- a/libtommath/bn_mp_abs.c +++ b/libtommath/bn_mp_abs.c @@ -38,6 +38,6 @@ mp_abs (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_abs.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_add.c b/libtommath/bn_mp_add.c index be20644..122c850 100644 --- a/libtommath/bn_mp_add.c +++ b/libtommath/bn_mp_add.c @@ -48,6 +48,6 @@ int mp_add (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_add.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_add_d.c b/libtommath/bn_mp_add_d.c index 8ca36c1..aec8fc8 100644 --- a/libtommath/bn_mp_add_d.c +++ b/libtommath/bn_mp_add_d.c @@ -107,6 +107,6 @@ mp_add_d (mp_int * a, mp_digit b, mp_int * c) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_add_d.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_addmod.c b/libtommath/bn_mp_addmod.c index 6d8afe1..0376659 100644 --- a/libtommath/bn_mp_addmod.c +++ b/libtommath/bn_mp_addmod.c @@ -36,6 +36,6 @@ mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_addmod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_and.c b/libtommath/bn_mp_and.c index 8ea2287..22dfbff 100644 --- a/libtommath/bn_mp_and.c +++ b/libtommath/bn_mp_and.c @@ -52,6 +52,6 @@ mp_and (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_and.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_clamp.c b/libtommath/bn_mp_clamp.c index 359c2ff..1e0c817 100644 --- a/libtommath/bn_mp_clamp.c +++ b/libtommath/bn_mp_clamp.c @@ -39,6 +39,6 @@ mp_clamp (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_clamp.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_clear.c b/libtommath/bn_mp_clear.c index a65f0a3..72301df 100644 --- a/libtommath/bn_mp_clear.c +++ b/libtommath/bn_mp_clear.c @@ -39,6 +39,6 @@ mp_clear (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_clear.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_clear_multi.c b/libtommath/bn_mp_clear_multi.c index daaea79..6bbc10c 100644 --- a/libtommath/bn_mp_clear_multi.c +++ b/libtommath/bn_mp_clear_multi.c @@ -29,6 +29,6 @@ void mp_clear_multi(mp_int *mp, ...) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_clear_multi.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_cmp.c b/libtommath/bn_mp_cmp.c index 533f36b..77d00cd 100644 --- a/libtommath/bn_mp_cmp.c +++ b/libtommath/bn_mp_cmp.c @@ -38,6 +38,6 @@ mp_cmp (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_cmp.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_cmp_d.c b/libtommath/bn_mp_cmp_d.c index 724c1c3..0d5bcb4 100644 --- a/libtommath/bn_mp_cmp_d.c +++ b/libtommath/bn_mp_cmp_d.c @@ -39,6 +39,6 @@ int mp_cmp_d(mp_int * a, mp_digit b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_cmp_d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_cmp_mag.c b/libtommath/bn_mp_cmp_mag.c index 693eb7c..063fd18 100644 --- a/libtommath/bn_mp_cmp_mag.c +++ b/libtommath/bn_mp_cmp_mag.c @@ -50,6 +50,6 @@ int mp_cmp_mag (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_cmp_mag.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_cnt_lsb.c b/libtommath/bn_mp_cnt_lsb.c index 66d1a74..efebd2a 100644 --- a/libtommath/bn_mp_cnt_lsb.c +++ b/libtommath/bn_mp_cnt_lsb.c @@ -48,6 +48,6 @@ int mp_cnt_lsb(mp_int *a) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_cnt_lsb.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_copy.c b/libtommath/bn_mp_copy.c index b0de16d..45cac61 100644 --- a/libtommath/bn_mp_copy.c +++ b/libtommath/bn_mp_copy.c @@ -63,6 +63,6 @@ mp_copy (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_copy.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_count_bits.c b/libtommath/bn_mp_count_bits.c index 8bc5657..6c02ec6 100644 --- a/libtommath/bn_mp_count_bits.c +++ b/libtommath/bn_mp_count_bits.c @@ -40,6 +40,6 @@ mp_count_bits (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_count_bits.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_div.c b/libtommath/bn_mp_div.c index aee9c94..af5c55d 100644 --- a/libtommath/bn_mp_div.c +++ b/libtommath/bn_mp_div.c @@ -287,6 +287,6 @@ LBL_Q:mp_clear (&q); #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_div.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_div_2.c b/libtommath/bn_mp_div_2.c index 7ee3e5b..64ef823 100644 --- a/libtommath/bn_mp_div_2.c +++ b/libtommath/bn_mp_div_2.c @@ -63,6 +63,6 @@ int mp_div_2(mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_div_2.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_div_2d.c b/libtommath/bn_mp_div_2d.c index 4f7fa59..72936a4 100644 --- a/libtommath/bn_mp_div_2d.c +++ b/libtommath/bn_mp_div_2d.c @@ -92,6 +92,6 @@ int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_div_2d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_div_3.c b/libtommath/bn_mp_div_3.c index 3c60269..7f6869b 100644 --- a/libtommath/bn_mp_div_3.c +++ b/libtommath/bn_mp_div_3.c @@ -74,6 +74,6 @@ mp_div_3 (mp_int * a, mp_int *c, mp_digit * d) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_div_3.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_div_d.c b/libtommath/bn_mp_div_d.c index 6a26d4f..ca34e87 100644 --- a/libtommath/bn_mp_div_d.c +++ b/libtommath/bn_mp_div_d.c @@ -110,6 +110,6 @@ int mp_div_d (mp_int * a, mp_digit b, mp_int * c, mp_digit * d) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_div_d.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2007/01/09 04:44:32 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_dr_is_modulus.c b/libtommath/bn_mp_dr_is_modulus.c index 5237344..52b4fdf 100644 --- a/libtommath/bn_mp_dr_is_modulus.c +++ b/libtommath/bn_mp_dr_is_modulus.c @@ -38,6 +38,6 @@ int mp_dr_is_modulus(mp_int *a) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_dr_is_modulus.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_dr_reduce.c b/libtommath/bn_mp_dr_reduce.c index e60b578..47f0c60 100644 --- a/libtommath/bn_mp_dr_reduce.c +++ b/libtommath/bn_mp_dr_reduce.c @@ -89,6 +89,6 @@ top: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_dr_reduce.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_dr_setup.c b/libtommath/bn_mp_dr_setup.c index 1d7d856..99ee67d 100644 --- a/libtommath/bn_mp_dr_setup.c +++ b/libtommath/bn_mp_dr_setup.c @@ -27,6 +27,6 @@ void mp_dr_setup(mp_int *a, mp_digit *d) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_dr_setup.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_exch.c b/libtommath/bn_mp_exch.c index 38574e0..dd3098e 100644 --- a/libtommath/bn_mp_exch.c +++ b/libtommath/bn_mp_exch.c @@ -29,6 +29,6 @@ mp_exch (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_exch.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_expt_d.c b/libtommath/bn_mp_expt_d.c index 4bdc2d1..f9357cc 100644 --- a/libtommath/bn_mp_expt_d.c +++ b/libtommath/bn_mp_expt_d.c @@ -52,6 +52,6 @@ int mp_expt_d (mp_int * a, mp_digit b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_expt_d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_exptmod.c b/libtommath/bn_mp_exptmod.c index 0231916..8fbce19 100644 --- a/libtommath/bn_mp_exptmod.c +++ b/libtommath/bn_mp_exptmod.c @@ -107,6 +107,6 @@ int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_exptmod.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_exptmod_fast.c b/libtommath/bn_mp_exptmod_fast.c index 2a3b3c9..60c7e2b 100644 --- a/libtommath/bn_mp_exptmod_fast.c +++ b/libtommath/bn_mp_exptmod_fast.c @@ -316,6 +316,6 @@ LBL_M: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_exptmod_fast.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_exteuclid.c b/libtommath/bn_mp_exteuclid.c index e6c4ce2..c65928d 100644 --- a/libtommath/bn_mp_exteuclid.c +++ b/libtommath/bn_mp_exteuclid.c @@ -77,6 +77,6 @@ _ERR: mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_exteuclid.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_fread.c b/libtommath/bn_mp_fread.c index b344b6f..a2e51a1 100644 --- a/libtommath/bn_mp_fread.c +++ b/libtommath/bn_mp_fread.c @@ -62,6 +62,6 @@ int mp_fread(mp_int *a, int radix, FILE *stream) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_fread.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_fwrite.c b/libtommath/bn_mp_fwrite.c index a0b4c6b..b3fd834 100644 --- a/libtommath/bn_mp_fwrite.c +++ b/libtommath/bn_mp_fwrite.c @@ -47,6 +47,6 @@ int mp_fwrite(mp_int *a, int radix, FILE *stream) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_fwrite.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_gcd.c b/libtommath/bn_mp_gcd.c index b39ba90..b45cfed 100644 --- a/libtommath/bn_mp_gcd.c +++ b/libtommath/bn_mp_gcd.c @@ -100,6 +100,6 @@ LBL_U:mp_clear (&v); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_gcd.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_get_int.c b/libtommath/bn_mp_get_int.c index 17162e2..11baa0e 100644 --- a/libtommath/bn_mp_get_int.c +++ b/libtommath/bn_mp_get_int.c @@ -40,6 +40,6 @@ unsigned long mp_get_int(mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_get_int.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_grow.c b/libtommath/bn_mp_grow.c index cf2b949..f1c1cab 100644 --- a/libtommath/bn_mp_grow.c +++ b/libtommath/bn_mp_grow.c @@ -52,6 +52,6 @@ int mp_grow (mp_int * a, int size) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_grow.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_init.c b/libtommath/bn_mp_init.c index 8be27f5..79cca3c 100644 --- a/libtommath/bn_mp_init.c +++ b/libtommath/bn_mp_init.c @@ -41,6 +41,6 @@ int mp_init (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_init_copy.c b/libtommath/bn_mp_init_copy.c index 0160811..8ce0ef9 100644 --- a/libtommath/bn_mp_init_copy.c +++ b/libtommath/bn_mp_init_copy.c @@ -27,6 +27,6 @@ int mp_init_copy (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init_copy.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_init_multi.c b/libtommath/bn_mp_init_multi.c index 59dc3a9..a40ea8e 100644 --- a/libtommath/bn_mp_init_multi.c +++ b/libtommath/bn_mp_init_multi.c @@ -54,6 +54,6 @@ int mp_init_multi(mp_int *mp, ...) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init_multi.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_init_set.c b/libtommath/bn_mp_init_set.c index 34edad9..f9b08e9 100644 --- a/libtommath/bn_mp_init_set.c +++ b/libtommath/bn_mp_init_set.c @@ -27,6 +27,6 @@ int mp_init_set (mp_int * a, mp_digit b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init_set.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_init_set_int.c b/libtommath/bn_mp_init_set_int.c index 5c55993..9473c3f 100644 --- a/libtommath/bn_mp_init_set_int.c +++ b/libtommath/bn_mp_init_set_int.c @@ -26,6 +26,6 @@ int mp_init_set_int (mp_int * a, unsigned long b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init_set_int.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_init_size.c b/libtommath/bn_mp_init_size.c index 8e01418..69dd49c 100644 --- a/libtommath/bn_mp_init_size.c +++ b/libtommath/bn_mp_init_size.c @@ -43,6 +43,6 @@ int mp_init_size (mp_int * a, int size) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init_size.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_invmod.c b/libtommath/bn_mp_invmod.c index 1546514..f4bdc17 100644 --- a/libtommath/bn_mp_invmod.c +++ b/libtommath/bn_mp_invmod.c @@ -38,6 +38,6 @@ int mp_invmod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_invmod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_invmod_slow.c b/libtommath/bn_mp_invmod_slow.c index eedd47d..2430f02 100644 --- a/libtommath/bn_mp_invmod_slow.c +++ b/libtommath/bn_mp_invmod_slow.c @@ -170,6 +170,6 @@ LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_invmod_slow.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_is_square.c b/libtommath/bn_mp_is_square.c index 50c5244..12b9ec7 100644 --- a/libtommath/bn_mp_is_square.c +++ b/libtommath/bn_mp_is_square.c @@ -104,6 +104,6 @@ ERR:mp_clear(&t); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_is_square.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_jacobi.c b/libtommath/bn_mp_jacobi.c index 91cfeea..07a9d65 100644 --- a/libtommath/bn_mp_jacobi.c +++ b/libtommath/bn_mp_jacobi.c @@ -100,6 +100,6 @@ LBL_A1:mp_clear (&a1); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_jacobi.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_karatsuba_mul.c b/libtommath/bn_mp_karatsuba_mul.c index 8ea2c27..62e885c 100644 --- a/libtommath/bn_mp_karatsuba_mul.c +++ b/libtommath/bn_mp_karatsuba_mul.c @@ -162,6 +162,6 @@ ERR: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_karatsuba_mul.c,v $ */ -/* $Revision: 1.6 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_karatsuba_sqr.c b/libtommath/bn_mp_karatsuba_sqr.c index a5e198b..ce5c753 100644 --- a/libtommath/bn_mp_karatsuba_sqr.c +++ b/libtommath/bn_mp_karatsuba_sqr.c @@ -116,6 +116,6 @@ ERR: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_karatsuba_sqr.c,v $ */ -/* $Revision: 1.6 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_lcm.c b/libtommath/bn_mp_lcm.c index 781eef5..a4115da 100644 --- a/libtommath/bn_mp_lcm.c +++ b/libtommath/bn_mp_lcm.c @@ -55,6 +55,6 @@ LBL_T: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_lcm.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_lshd.c b/libtommath/bn_mp_lshd.c index f118cf1..87c216b 100644 --- a/libtommath/bn_mp_lshd.c +++ b/libtommath/bn_mp_lshd.c @@ -62,6 +62,6 @@ int mp_lshd (mp_int * a, int b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_lshd.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_mod.c b/libtommath/bn_mp_mod.c index f5cf8d0..6828328 100644 --- a/libtommath/bn_mp_mod.c +++ b/libtommath/bn_mp_mod.c @@ -43,6 +43,6 @@ mp_mod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_mod_2d.c b/libtommath/bn_mp_mod_2d.c index e194a06..77f13c3 100644 --- a/libtommath/bn_mp_mod_2d.c +++ b/libtommath/bn_mp_mod_2d.c @@ -50,6 +50,6 @@ mp_mod_2d (mp_int * a, int b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mod_2d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_mod_d.c b/libtommath/bn_mp_mod_d.c index 9ca37e6..4ad3d90 100644 --- a/libtommath/bn_mp_mod_d.c +++ b/libtommath/bn_mp_mod_d.c @@ -22,6 +22,6 @@ mp_mod_d (mp_int * a, mp_digit b, mp_digit * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mod_d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_montgomery_calc_normalization.c b/libtommath/bn_mp_montgomery_calc_normalization.c index c669fe0..4825ab5 100644 --- a/libtommath/bn_mp_montgomery_calc_normalization.c +++ b/libtommath/bn_mp_montgomery_calc_normalization.c @@ -54,6 +54,6 @@ int mp_montgomery_calc_normalization (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_calc_normalization.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_montgomery_reduce.c b/libtommath/bn_mp_montgomery_reduce.c index b765090..3c73268 100644 --- a/libtommath/bn_mp_montgomery_reduce.c +++ b/libtommath/bn_mp_montgomery_reduce.c @@ -113,6 +113,6 @@ mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_reduce.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_montgomery_setup.c b/libtommath/bn_mp_montgomery_setup.c index f082749..0de27bb 100644 --- a/libtommath/bn_mp_montgomery_setup.c +++ b/libtommath/bn_mp_montgomery_setup.c @@ -54,6 +54,6 @@ mp_montgomery_setup (mp_int * n, mp_digit * rho) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_setup.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_mul.c b/libtommath/bn_mp_mul.c index 8b1117a..bd75d04 100644 --- a/libtommath/bn_mp_mul.c +++ b/libtommath/bn_mp_mul.c @@ -61,6 +61,6 @@ int mp_mul (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mul.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_mul_2.c b/libtommath/bn_mp_mul_2.c index 02455fc..6ba76be 100644 --- a/libtommath/bn_mp_mul_2.c +++ b/libtommath/bn_mp_mul_2.c @@ -77,6 +77,6 @@ int mp_mul_2(mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mul_2.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_mul_2d.c b/libtommath/bn_mp_mul_2d.c index efeff2e..385ac59 100644 --- a/libtommath/bn_mp_mul_2d.c +++ b/libtommath/bn_mp_mul_2d.c @@ -80,6 +80,6 @@ int mp_mul_2d (mp_int * a, int b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mul_2d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_mul_d.c b/libtommath/bn_mp_mul_d.c index 00f9a89..13c6066 100644 --- a/libtommath/bn_mp_mul_d.c +++ b/libtommath/bn_mp_mul_d.c @@ -74,6 +74,6 @@ mp_mul_d (mp_int * a, mp_digit b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mul_d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_mulmod.c b/libtommath/bn_mp_mulmod.c index 003ceb9..eebca37 100644 --- a/libtommath/bn_mp_mulmod.c +++ b/libtommath/bn_mp_mulmod.c @@ -35,6 +35,6 @@ int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mulmod.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_n_root.c b/libtommath/bn_mp_n_root.c index 0e7bedc..e6bf725 100644 --- a/libtommath/bn_mp_n_root.c +++ b/libtommath/bn_mp_n_root.c @@ -127,6 +127,6 @@ LBL_T1:mp_clear (&t1); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_n_root.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_neg.c b/libtommath/bn_mp_neg.c index a7d035a..0e868ce 100644 --- a/libtommath/bn_mp_neg.c +++ b/libtommath/bn_mp_neg.c @@ -35,6 +35,6 @@ int mp_neg (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_neg.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_or.c b/libtommath/bn_mp_or.c index bff4995..5c2761a 100644 --- a/libtommath/bn_mp_or.c +++ b/libtommath/bn_mp_or.c @@ -45,6 +45,6 @@ int mp_or (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_or.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_prime_fermat.c b/libtommath/bn_mp_prime_fermat.c index c23d77f..fe10ab2 100644 --- a/libtommath/bn_mp_prime_fermat.c +++ b/libtommath/bn_mp_prime_fermat.c @@ -57,6 +57,6 @@ LBL_T:mp_clear (&t); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_fermat.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_prime_is_divisible.c b/libtommath/bn_mp_prime_is_divisible.c index 8e7871c..2b217ae 100644 --- a/libtommath/bn_mp_prime_is_divisible.c +++ b/libtommath/bn_mp_prime_is_divisible.c @@ -45,6 +45,6 @@ int mp_prime_is_divisible (mp_int * a, int *result) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_is_divisible.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_prime_is_prime.c b/libtommath/bn_mp_prime_is_prime.c index c316d62..09908df 100644 --- a/libtommath/bn_mp_prime_is_prime.c +++ b/libtommath/bn_mp_prime_is_prime.c @@ -78,6 +78,6 @@ LBL_B:mp_clear (&b); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_is_prime.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_prime_miller_rabin.c b/libtommath/bn_mp_prime_miller_rabin.c index ddf0358..fe88d94 100644 --- a/libtommath/bn_mp_prime_miller_rabin.c +++ b/libtommath/bn_mp_prime_miller_rabin.c @@ -98,6 +98,6 @@ LBL_N1:mp_clear (&n1); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_miller_rabin.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_prime_next_prime.c b/libtommath/bn_mp_prime_next_prime.c index daf2ec7..37a03c6 100644 --- a/libtommath/bn_mp_prime_next_prime.c +++ b/libtommath/bn_mp_prime_next_prime.c @@ -143,7 +143,7 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style) /* is this prime? */ for (x = 0; x < t; x++) { - mp_set(&b, ltm_prime_tab[t]); + mp_set(&b, ltm_prime_tab[x]); if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) { goto LBL_ERR; } @@ -165,6 +165,6 @@ LBL_ERR: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_next_prime.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: v0.42.0 $ */ +/* $Date: 2010-07-15 13:49:00 +0000 $ */ diff --git a/libtommath/bn_mp_prime_rabin_miller_trials.c b/libtommath/bn_mp_prime_rabin_miller_trials.c index 248c2fd..b4fc323 100644 --- a/libtommath/bn_mp_prime_rabin_miller_trials.c +++ b/libtommath/bn_mp_prime_rabin_miller_trials.c @@ -47,6 +47,6 @@ int mp_prime_rabin_miller_trials(int size) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_rabin_miller_trials.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_prime_random_ex.c b/libtommath/bn_mp_prime_random_ex.c index 07aae4b..16d2aae 100644 --- a/libtommath/bn_mp_prime_random_ex.c +++ b/libtommath/bn_mp_prime_random_ex.c @@ -120,6 +120,6 @@ error: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_random_ex.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_radix_size.c b/libtommath/bn_mp_radix_size.c index 1b61e3a..9d95c48 100644 --- a/libtommath/bn_mp_radix_size.c +++ b/libtommath/bn_mp_radix_size.c @@ -73,6 +73,6 @@ int mp_radix_size (mp_int * a, int radix, int *size) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_radix_size.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_radix_smap.c b/libtommath/bn_mp_radix_smap.c index 7d72feb..b3abd3e 100644 --- a/libtommath/bn_mp_radix_smap.c +++ b/libtommath/bn_mp_radix_smap.c @@ -19,6 +19,6 @@ const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_radix_smap.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_rand.c b/libtommath/bn_mp_rand.c index af66a67..96e4e46 100644 --- a/libtommath/bn_mp_rand.c +++ b/libtommath/bn_mp_rand.c @@ -50,6 +50,6 @@ mp_rand (mp_int * a, int digits) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_rand.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_read_radix.c b/libtommath/bn_mp_read_radix.c index 91c46c2..8ce103f 100644 --- a/libtommath/bn_mp_read_radix.c +++ b/libtommath/bn_mp_read_radix.c @@ -80,6 +80,6 @@ int mp_read_radix (mp_int * a, const char *str, int radix) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_read_radix.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_read_signed_bin.c b/libtommath/bn_mp_read_signed_bin.c index 8da651c..92924e8 100644 --- a/libtommath/bn_mp_read_signed_bin.c +++ b/libtommath/bn_mp_read_signed_bin.c @@ -36,6 +36,6 @@ int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_read_signed_bin.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_read_unsigned_bin.c b/libtommath/bn_mp_read_unsigned_bin.c index 1ebba13..5a7fa91 100644 --- a/libtommath/bn_mp_read_unsigned_bin.c +++ b/libtommath/bn_mp_read_unsigned_bin.c @@ -50,6 +50,6 @@ int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_read_unsigned_bin.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_reduce.c b/libtommath/bn_mp_reduce.c index 21d0730..50e1eaa 100644 --- a/libtommath/bn_mp_reduce.c +++ b/libtommath/bn_mp_reduce.c @@ -95,6 +95,6 @@ CLEANUP: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_reduce_2k.c b/libtommath/bn_mp_reduce_2k.c index d9620c2..6bbc5f1 100644 --- a/libtommath/bn_mp_reduce_2k.c +++ b/libtommath/bn_mp_reduce_2k.c @@ -56,6 +56,6 @@ ERR: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_reduce_2k_l.c b/libtommath/bn_mp_reduce_2k_l.c index f06103d..067122a 100644 --- a/libtommath/bn_mp_reduce_2k_l.c +++ b/libtommath/bn_mp_reduce_2k_l.c @@ -57,6 +57,6 @@ ERR: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_l.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_reduce_2k_setup.c b/libtommath/bn_mp_reduce_2k_setup.c index a80e7a2..3f9ffd9 100644 --- a/libtommath/bn_mp_reduce_2k_setup.c +++ b/libtommath/bn_mp_reduce_2k_setup.c @@ -42,6 +42,6 @@ int mp_reduce_2k_setup(mp_int *a, mp_digit *d) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_setup.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_reduce_2k_setup_l.c b/libtommath/bn_mp_reduce_2k_setup_l.c index 7cf002e..686368e 100644 --- a/libtommath/bn_mp_reduce_2k_setup_l.c +++ b/libtommath/bn_mp_reduce_2k_setup_l.c @@ -39,6 +39,6 @@ ERR: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_setup_l.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_reduce_is_2k.c b/libtommath/bn_mp_reduce_is_2k.c index 7308be7..08b62ff 100644 --- a/libtommath/bn_mp_reduce_is_2k.c +++ b/libtommath/bn_mp_reduce_is_2k.c @@ -47,6 +47,6 @@ int mp_reduce_is_2k(mp_int *a) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_is_2k.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_reduce_is_2k_l.c b/libtommath/bn_mp_reduce_is_2k_l.c index 14a4d21..a72e39c 100644 --- a/libtommath/bn_mp_reduce_is_2k_l.c +++ b/libtommath/bn_mp_reduce_is_2k_l.c @@ -39,6 +39,6 @@ int mp_reduce_is_2k_l(mp_int *a) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_is_2k_l.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_reduce_setup.c b/libtommath/bn_mp_reduce_setup.c index 370f20b..f017386 100644 --- a/libtommath/bn_mp_reduce_setup.c +++ b/libtommath/bn_mp_reduce_setup.c @@ -29,6 +29,6 @@ int mp_reduce_setup (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_setup.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_rshd.c b/libtommath/bn_mp_rshd.c index 2a693c5..bb506e9 100644 --- a/libtommath/bn_mp_rshd.c +++ b/libtommath/bn_mp_rshd.c @@ -67,6 +67,6 @@ void mp_rshd (mp_int * a, int b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_rshd.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_set.c b/libtommath/bn_mp_set.c index 174adcb..412673a 100644 --- a/libtommath/bn_mp_set.c +++ b/libtommath/bn_mp_set.c @@ -24,6 +24,6 @@ void mp_set (mp_int * a, mp_digit b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_set.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_set_int.c b/libtommath/bn_mp_set_int.c index cf10ea1..17cfe89 100644 --- a/libtommath/bn_mp_set_int.c +++ b/libtommath/bn_mp_set_int.c @@ -43,6 +43,6 @@ int mp_set_int (mp_int * a, unsigned long b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_set_int.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_shrink.c b/libtommath/bn_mp_shrink.c index 4b8c5ef..2bee381 100644 --- a/libtommath/bn_mp_shrink.c +++ b/libtommath/bn_mp_shrink.c @@ -19,17 +19,22 @@ int mp_shrink (mp_int * a) { mp_digit *tmp; - if (a->alloc != a->used && a->used > 0) { - if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * a->used)) == NULL) { + int used = 1; + + if(a->used > 0) + used = a->used; + + if (a->alloc != used) { + if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * used)) == NULL) { return MP_MEM; } a->dp = tmp; - a->alloc = a->used; + a->alloc = used; } return MP_OKAY; } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_shrink.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: v0.42.0 $ */ +/* $Date: 2010-06-02 15:09:36 +0200 $ */ diff --git a/libtommath/bn_mp_signed_bin_size.c b/libtommath/bn_mp_signed_bin_size.c index 6739d19..b28d402 100644 --- a/libtommath/bn_mp_signed_bin_size.c +++ b/libtommath/bn_mp_signed_bin_size.c @@ -22,6 +22,6 @@ int mp_signed_bin_size (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_signed_bin_size.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_sqr.c b/libtommath/bn_mp_sqr.c index 868ccbb..b085668 100644 --- a/libtommath/bn_mp_sqr.c +++ b/libtommath/bn_mp_sqr.c @@ -53,6 +53,6 @@ if (a->used >= KARATSUBA_SQR_CUTOFF) { } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_sqr.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_sqrmod.c b/libtommath/bn_mp_sqrmod.c index 161cbbb..369028b 100644 --- a/libtommath/bn_mp_sqrmod.c +++ b/libtommath/bn_mp_sqrmod.c @@ -36,6 +36,6 @@ mp_sqrmod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_sqrmod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_sqrt.c b/libtommath/bn_mp_sqrt.c index 8fd057c..983e41c 100644 --- a/libtommath/bn_mp_sqrt.c +++ b/libtommath/bn_mp_sqrt.c @@ -76,6 +76,6 @@ E2: mp_clear(&t1); #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_sqrt.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_sub.c b/libtommath/bn_mp_sub.c index f5015cc..3c8e5d4 100644 --- a/libtommath/bn_mp_sub.c +++ b/libtommath/bn_mp_sub.c @@ -54,6 +54,6 @@ mp_sub (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_sub.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_sub_d.c b/libtommath/bn_mp_sub_d.c index 06cdca6..13b49bc 100644 --- a/libtommath/bn_mp_sub_d.c +++ b/libtommath/bn_mp_sub_d.c @@ -88,6 +88,6 @@ mp_sub_d (mp_int * a, mp_digit b, mp_int * c) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_sub_d.c,v $ */ -/* $Revision: 1.6 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_submod.c b/libtommath/bn_mp_submod.c index 869e23c..d919c17 100644 --- a/libtommath/bn_mp_submod.c +++ b/libtommath/bn_mp_submod.c @@ -37,6 +37,6 @@ mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_submod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_to_signed_bin.c b/libtommath/bn_mp_to_signed_bin.c index 9df83ca..dda9285 100644 --- a/libtommath/bn_mp_to_signed_bin.c +++ b/libtommath/bn_mp_to_signed_bin.c @@ -28,6 +28,6 @@ int mp_to_signed_bin (mp_int * a, unsigned char *b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_to_signed_bin.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_to_signed_bin_n.c b/libtommath/bn_mp_to_signed_bin_n.c index 677f827..9e3b011 100644 --- a/libtommath/bn_mp_to_signed_bin_n.c +++ b/libtommath/bn_mp_to_signed_bin_n.c @@ -26,6 +26,6 @@ int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_to_signed_bin_n.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_to_unsigned_bin.c b/libtommath/bn_mp_to_unsigned_bin.c index c137f10..76072a9 100644 --- a/libtommath/bn_mp_to_unsigned_bin.c +++ b/libtommath/bn_mp_to_unsigned_bin.c @@ -43,6 +43,6 @@ int mp_to_unsigned_bin (mp_int * a, unsigned char *b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_to_unsigned_bin.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_to_unsigned_bin_n.c b/libtommath/bn_mp_to_unsigned_bin_n.c index 0dc00c6..51028d8 100644 --- a/libtommath/bn_mp_to_unsigned_bin_n.c +++ b/libtommath/bn_mp_to_unsigned_bin_n.c @@ -26,6 +26,6 @@ int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_to_unsigned_bin_n.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_toom_mul.c b/libtommath/bn_mp_toom_mul.c index ad5d9e9..e0fd772 100644 --- a/libtommath/bn_mp_toom_mul.c +++ b/libtommath/bn_mp_toom_mul.c @@ -279,6 +279,6 @@ ERR: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_toom_mul.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_toom_sqr.c b/libtommath/bn_mp_toom_sqr.c index 48880d0..9076e6f 100644 --- a/libtommath/bn_mp_toom_sqr.c +++ b/libtommath/bn_mp_toom_sqr.c @@ -221,6 +221,6 @@ ERR: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_toom_sqr.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_toradix.c b/libtommath/bn_mp_toradix.c index 0adc28d..bb95783 100644 --- a/libtommath/bn_mp_toradix.c +++ b/libtommath/bn_mp_toradix.c @@ -70,6 +70,6 @@ int mp_toradix (mp_int * a, char *str, int radix) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_toradix.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_toradix_n.c b/libtommath/bn_mp_toradix_n.c index 796ed55..7e425d6 100644 --- a/libtommath/bn_mp_toradix_n.c +++ b/libtommath/bn_mp_toradix_n.c @@ -83,6 +83,6 @@ int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_toradix_n.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_unsigned_bin_size.c b/libtommath/bn_mp_unsigned_bin_size.c index 6dc3bd5..b16fdcd 100644 --- a/libtommath/bn_mp_unsigned_bin_size.c +++ b/libtommath/bn_mp_unsigned_bin_size.c @@ -23,6 +23,6 @@ int mp_unsigned_bin_size (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_unsigned_bin_size.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_xor.c b/libtommath/bn_mp_xor.c index 59ff2e1..5744556 100644 --- a/libtommath/bn_mp_xor.c +++ b/libtommath/bn_mp_xor.c @@ -46,6 +46,6 @@ mp_xor (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_xor.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_mp_zero.c b/libtommath/bn_mp_zero.c index b0977d4..99e6df2 100644 --- a/libtommath/bn_mp_zero.c +++ b/libtommath/bn_mp_zero.c @@ -31,6 +31,6 @@ void mp_zero (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_zero.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_prime_tab.c b/libtommath/bn_prime_tab.c index bd25247..fb5ad08 100644 --- a/libtommath/bn_prime_tab.c +++ b/libtommath/bn_prime_tab.c @@ -56,6 +56,6 @@ const mp_digit ltm_prime_tab[] = { }; #endif -/* $Source: /cvs/libtom/libtommath/bn_prime_tab.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_reverse.c b/libtommath/bn_reverse.c index ddfa827..17cdcc1 100644 --- a/libtommath/bn_reverse.c +++ b/libtommath/bn_reverse.c @@ -34,6 +34,6 @@ bn_reverse (unsigned char *s, int len) } #endif -/* $Source: /cvs/libtom/libtommath/bn_reverse.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_s_mp_add.c b/libtommath/bn_s_mp_add.c index f034ae6..0ca20b8 100644 --- a/libtommath/bn_s_mp_add.c +++ b/libtommath/bn_s_mp_add.c @@ -104,6 +104,6 @@ s_mp_add (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_add.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_s_mp_exptmod.c b/libtommath/bn_s_mp_exptmod.c index 097d894..bc02a28 100644 --- a/libtommath/bn_s_mp_exptmod.c +++ b/libtommath/bn_s_mp_exptmod.c @@ -247,6 +247,6 @@ LBL_M: } #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_exptmod.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_s_mp_mul_digs.c b/libtommath/bn_s_mp_mul_digs.c index f5bbf39..86196bf 100644 --- a/libtommath/bn_s_mp_mul_digs.c +++ b/libtommath/bn_s_mp_mul_digs.c @@ -85,6 +85,6 @@ int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_mul_digs.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_s_mp_mul_high_digs.c b/libtommath/bn_s_mp_mul_high_digs.c index 2b718f2..019014e 100644 --- a/libtommath/bn_s_mp_mul_high_digs.c +++ b/libtommath/bn_s_mp_mul_high_digs.c @@ -76,6 +76,6 @@ s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_mul_high_digs.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_s_mp_sqr.c b/libtommath/bn_s_mp_sqr.c index d2531c2..90c465d 100644 --- a/libtommath/bn_s_mp_sqr.c +++ b/libtommath/bn_s_mp_sqr.c @@ -79,6 +79,6 @@ int s_mp_sqr (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_sqr.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bn_s_mp_sub.c b/libtommath/bn_s_mp_sub.c index 6a60c39..ccea6bd 100644 --- a/libtommath/bn_s_mp_sub.c +++ b/libtommath/bn_s_mp_sub.c @@ -84,6 +84,6 @@ s_mp_sub (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_sub.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/bncore.c b/libtommath/bncore.c index 8fb1824..1a0ac2c 100644 --- a/libtommath/bncore.c +++ b/libtommath/bncore.c @@ -31,6 +31,6 @@ int KARATSUBA_MUL_CUTOFF = 80, /* Min. number of digits before Karatsub TOOM_SQR_CUTOFF = 400; #endif -/* $Source: /cvs/libtom/libtommath/bncore.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ diff --git a/libtommath/changes.txt b/libtommath/changes.txt index b0da4da..4fc0913 100644 --- a/libtommath/changes.txt +++ b/libtommath/changes.txt @@ -1,3 +1,9 @@ +July 23rd, 2010 +v0.42.0 + -- Fix for mp_prime_next_prime() bug when checking generated prime + -- allow mp_shrink to shrink initialized, but empty MPI's + -- Added project and solution files for Visual Studio 2005 and Visual Studio 2008. + March 10th, 2007 v0.41 -- Wolfgang Ehrhardt suggested a quick fix to mp_div_d() which makes the detection of powers of two quicker. -- [CRI] Added libtommath.dsp for Visual C++ users. diff --git a/libtommath/demo/demo.c b/libtommath/demo/demo.c index bb5eb44..3e5663b 100644 --- a/libtommath/demo/demo.c +++ b/libtommath/demo/demo.c @@ -735,6 +735,6 @@ printf("compare no compare!\n"); exit(EXIT_FAILURE); } return 0; } -/* $Source: /cvs/libtom/libtommath/demo/demo.c,v $ */ -/* $Revision: 1.3 $ */ -/* $Date: 2005/06/24 11:32:07 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/demo/timing.c b/libtommath/demo/timing.c index d4660a9..57bb6d4 100644 --- a/libtommath/demo/timing.c +++ b/libtommath/demo/timing.c @@ -314,6 +314,6 @@ int main(void) return 0; } -/* $Source: /cvs/libtom/libtommath/demo/timing.c,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2005/05/05 14:38:47 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/etc/2kprime.c b/libtommath/etc/2kprime.c index c09818f..fff4825 100644 --- a/libtommath/etc/2kprime.c +++ b/libtommath/etc/2kprime.c @@ -79,6 +79,6 @@ int main(void) -/* $Source: /cvs/libtom/libtommath/etc/2kprime.c,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2005/05/05 14:38:47 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/etc/drprime.c b/libtommath/etc/drprime.c index e413985..ea40bd3 100644 --- a/libtommath/etc/drprime.c +++ b/libtommath/etc/drprime.c @@ -59,6 +59,6 @@ int main(void) } -/* $Source: /cvs/libtom/libtommath/etc/drprime.c,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2005/05/05 14:38:47 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/etc/mersenne.c b/libtommath/etc/mersenne.c index 6a6497a..6f9eed2 100644 --- a/libtommath/etc/mersenne.c +++ b/libtommath/etc/mersenne.c @@ -139,6 +139,6 @@ main (void) return 0; } -/* $Source: /cvs/libtom/libtommath/etc/mersenne.c,v $ */ -/* $Revision: 1.3 $ */ -/* $Date: 2006/03/31 14:18:47 $ */ +/* $Source$ */ +/* $Revision: 0.39 $ */ +/* $Date: 2006-04-06 19:49:59 +0000 $ */ diff --git a/libtommath/etc/mont.c b/libtommath/etc/mont.c index 393be4c..8356903 100644 --- a/libtommath/etc/mont.c +++ b/libtommath/etc/mont.c @@ -45,6 +45,6 @@ int main(void) -/* $Source: /cvs/libtom/libtommath/etc/mont.c,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2005/05/05 14:38:47 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/etc/pprime.c b/libtommath/etc/pprime.c index 317e2a0..d2d3a32 100644 --- a/libtommath/etc/pprime.c +++ b/libtommath/etc/pprime.c @@ -395,6 +395,6 @@ main (void) return 0; } -/* $Source: /cvs/libtom/libtommath/etc/pprime.c,v $ */ -/* $Revision: 1.3 $ */ -/* $Date: 2006/03/31 14:18:47 $ */ +/* $Source$ */ +/* $Revision: 0.39 $ */ +/* $Date: 2006-04-06 19:49:59 +0000 $ */ diff --git a/libtommath/etc/tune.c b/libtommath/etc/tune.c index d4a502c..0094f19 100644 --- a/libtommath/etc/tune.c +++ b/libtommath/etc/tune.c @@ -137,6 +137,6 @@ main (void) return 0; } -/* $Source: /cvs/libtom/libtommath/etc/tune.c,v $ */ -/* $Revision: 1.3 $ */ -/* $Date: 2006/03/31 14:18:47 $ */ +/* $Source$ */ +/* $Revision: 0.39 $ */ +/* $Date: 2006-04-06 19:49:59 +0000 $ */ diff --git a/libtommath/libtommath_VS2005.sln b/libtommath/libtommath_VS2005.sln new file mode 100755 index 0000000..21bc915 --- /dev/null +++ b/libtommath/libtommath_VS2005.sln @@ -0,0 +1,20 @@ + +Microsoft Visual Studio Solution File, Format Version 9.00 +# Visual Studio 2005 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "libtommath", "libtommath_VS2005.vcproj", "{0272C9B2-D68B-4F24-B32D-C1FD552F7E51}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Win32 = Debug|Win32 + Release|Win32 = Release|Win32 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {0272C9B2-D68B-4F24-B32D-C1FD552F7E51}.Debug|Win32.ActiveCfg = Debug|Win32 + {0272C9B2-D68B-4F24-B32D-C1FD552F7E51}.Debug|Win32.Build.0 = Debug|Win32 + {0272C9B2-D68B-4F24-B32D-C1FD552F7E51}.Release|Win32.ActiveCfg = Release|Win32 + {0272C9B2-D68B-4F24-B32D-C1FD552F7E51}.Release|Win32.Build.0 = Release|Win32 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/libtommath/libtommath_VS2005.vcproj b/libtommath/libtommath_VS2005.vcproj new file mode 100755 index 0000000..7162185 --- /dev/null +++ b/libtommath/libtommath_VS2005.vcproj @@ -0,0 +1,2803 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/libtommath/libtommath_VS2008.sln b/libtommath/libtommath_VS2008.sln new file mode 100755 index 0000000..1327ccf --- /dev/null +++ b/libtommath/libtommath_VS2008.sln @@ -0,0 +1,20 @@ + +Microsoft Visual Studio Solution File, Format Version 10.00 +# Visual Studio 2008 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "libtommath", "libtommath_VS2008.vcproj", "{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Win32 = Debug|Win32 + Release|Win32 = Release|Win32 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Debug|Win32.ActiveCfg = Debug|Win32 + {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Debug|Win32.Build.0 = Debug|Win32 + {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Release|Win32.ActiveCfg = Release|Win32 + {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Release|Win32.Build.0 = Release|Win32 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/libtommath/libtommath_VS2008.vcproj b/libtommath/libtommath_VS2008.vcproj new file mode 100755 index 0000000..205aec1 --- /dev/null +++ b/libtommath/libtommath_VS2008.vcproj @@ -0,0 +1,2805 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/libtommath/makefile b/libtommath/makefile index 3e254d4..70de306 100644 --- a/libtommath/makefile +++ b/libtommath/makefile @@ -3,7 +3,7 @@ #Tom St Denis #version of library -VERSION=0.41 +VERSION=0.42.0 CFLAGS += -I./ -Wall -W -Wshadow -Wsign-compare diff --git a/libtommath/mtest/logtab.h b/libtommath/mtest/logtab.h index bbefaef..04c1ad3 100644 --- a/libtommath/mtest/logtab.h +++ b/libtommath/mtest/logtab.h @@ -19,6 +19,6 @@ const float s_logv_2[] = { }; -/* $Source: /cvs/libtom/libtommath/mtest/logtab.h,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2005/05/05 14:38:47 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/mtest/mpi-config.h b/libtommath/mtest/mpi-config.h index 6049c25..21e72b2 100644 --- a/libtommath/mtest/mpi-config.h +++ b/libtommath/mtest/mpi-config.h @@ -1,5 +1,5 @@ /* Default configuration for MPI library */ -/* $Id: mpi-config.h,v 1.2 2005/05/05 14:38:47 tom Exp $ */ +/* $ID$ */ #ifndef MPI_CONFIG_H_ #define MPI_CONFIG_H_ @@ -85,6 +85,6 @@ /* crc==3287762869, version==2, Sat Feb 02 06:43:53 2002 */ -/* $Source: /cvs/libtom/libtommath/mtest/mpi-config.h,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2005/05/05 14:38:47 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/mtest/mpi-types.h b/libtommath/mtest/mpi-types.h index 026de58..a90f11e 100644 --- a/libtommath/mtest/mpi-types.h +++ b/libtommath/mtest/mpi-types.h @@ -15,6 +15,6 @@ typedef int mp_err; #define RADIX (MP_DIGIT_MAX+1) -/* $Source: /cvs/libtom/libtommath/mtest/mpi-types.h,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2005/05/05 14:38:47 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/mtest/mpi.c b/libtommath/mtest/mpi.c index 7c712dd..f6ef8c7 100644 --- a/libtommath/mtest/mpi.c +++ b/libtommath/mtest/mpi.c @@ -6,7 +6,7 @@ Arbitrary precision integer arithmetic library - $Id: mpi.c,v 1.2 2005/05/05 14:38:47 tom Exp $ + $ID$ */ #include "mpi.h" @@ -3980,6 +3980,6 @@ int s_mp_outlen(int bits, int r) /* HERE THERE BE DRAGONS */ /* crc==4242132123, version==2, Sat Feb 02 06:43:52 2002 */ -/* $Source: /cvs/libtom/libtommath/mtest/mpi.c,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2005/05/05 14:38:47 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/mtest/mpi.h b/libtommath/mtest/mpi.h index 66ae873..526c3fd 100644 --- a/libtommath/mtest/mpi.h +++ b/libtommath/mtest/mpi.h @@ -6,7 +6,7 @@ Arbitrary precision integer arithmetic library - $Id: mpi.h,v 1.2 2005/05/05 14:38:47 tom Exp $ + $ID$ */ #ifndef _H_MPI_ @@ -226,6 +226,6 @@ const char *mp_strerror(mp_err ec); #endif /* end _H_MPI_ */ -/* $Source: /cvs/libtom/libtommath/mtest/mpi.h,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2005/05/05 14:38:47 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/mtest/mtest.c b/libtommath/mtest/mtest.c index bdfe612..92f03ad 100644 --- a/libtommath/mtest/mtest.c +++ b/libtommath/mtest/mtest.c @@ -303,6 +303,6 @@ int main(void) return 0; } -/* $Source: /cvs/libtom/libtommath/mtest/mtest.c,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2005/05/05 14:38:47 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/poster.pdf b/libtommath/poster.pdf index f3768d7..dc80fbb 100644 Binary files a/libtommath/poster.pdf and b/libtommath/poster.pdf differ diff --git a/libtommath/pre_gen/mpi.c b/libtommath/pre_gen/mpi.c index b7f4d47..7ba9d83 100644 --- a/libtommath/pre_gen/mpi.c +++ b/libtommath/pre_gen/mpi.c @@ -43,9 +43,9 @@ char *mp_error_to_string(int code) #endif -/* $Source: /cvs/libtom/libtommath/bn_error.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_error.c */ @@ -195,9 +195,9 @@ LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL); } #endif -/* $Source: /cvs/libtom/libtommath/bn_fast_mp_invmod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_fast_mp_invmod.c */ @@ -371,9 +371,9 @@ int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) } #endif -/* $Source: /cvs/libtom/libtommath/bn_fast_mp_montgomery_reduce.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_fast_mp_montgomery_reduce.c */ @@ -482,9 +482,9 @@ int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_mul_digs.c,v $ */ -/* $Revision: 1.8 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_fast_s_mp_mul_digs.c */ @@ -584,9 +584,9 @@ int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_mul_high_digs.c,v $ */ -/* $Revision: 1.6 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_fast_s_mp_mul_high_digs.c */ @@ -702,9 +702,9 @@ int fast_s_mp_sqr (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_sqr.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_fast_s_mp_sqr.c */ @@ -754,9 +754,9 @@ mp_2expt (mp_int * a, int b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_2expt.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_2expt.c */ @@ -801,9 +801,9 @@ mp_abs (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_abs.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_abs.c */ @@ -858,9 +858,9 @@ int mp_add (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_add.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_add.c */ @@ -974,9 +974,9 @@ mp_add_d (mp_int * a, mp_digit b, mp_int * c) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_add_d.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_add_d.c */ @@ -1019,9 +1019,9 @@ mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_addmod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_addmod.c */ @@ -1080,9 +1080,9 @@ mp_and (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_and.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_and.c */ @@ -1128,9 +1128,9 @@ mp_clamp (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_clamp.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_clamp.c */ @@ -1176,9 +1176,9 @@ mp_clear (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_clear.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_clear.c */ @@ -1214,9 +1214,9 @@ void mp_clear_multi(mp_int *mp, ...) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_clear_multi.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_clear_multi.c */ @@ -1261,9 +1261,9 @@ mp_cmp (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_cmp.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_cmp.c */ @@ -1309,9 +1309,9 @@ int mp_cmp_d(mp_int * a, mp_digit b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_cmp_d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_cmp_d.c */ @@ -1368,9 +1368,9 @@ int mp_cmp_mag (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_cmp_mag.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_cmp_mag.c */ @@ -1425,9 +1425,9 @@ int mp_cnt_lsb(mp_int *a) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_cnt_lsb.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_cnt_lsb.c */ @@ -1497,9 +1497,9 @@ mp_copy (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_copy.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_copy.c */ @@ -1546,9 +1546,9 @@ mp_count_bits (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_count_bits.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_count_bits.c */ @@ -1842,9 +1842,9 @@ LBL_Q:mp_clear (&q); #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_div.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_div.c */ @@ -1914,9 +1914,9 @@ int mp_div_2(mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_div_2.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_div_2.c */ @@ -2015,9 +2015,9 @@ int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_div_2d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_div_2d.c */ @@ -2098,9 +2098,9 @@ mp_div_3 (mp_int * a, mp_int *c, mp_digit * d) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_div_3.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_div_3.c */ @@ -2217,9 +2217,9 @@ int mp_div_d (mp_int * a, mp_digit b, mp_int * c, mp_digit * d) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_div_d.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2007/01/09 04:44:32 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_div_d.c */ @@ -2264,9 +2264,9 @@ int mp_dr_is_modulus(mp_int *a) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_dr_is_modulus.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_dr_is_modulus.c */ @@ -2362,9 +2362,9 @@ top: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_dr_reduce.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_dr_reduce.c */ @@ -2398,9 +2398,9 @@ void mp_dr_setup(mp_int *a, mp_digit *d) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_dr_setup.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_dr_setup.c */ @@ -2436,9 +2436,9 @@ mp_exch (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_exch.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_exch.c */ @@ -2497,9 +2497,9 @@ int mp_expt_d (mp_int * a, mp_digit b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_expt_d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_expt_d.c */ @@ -2613,9 +2613,9 @@ int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_exptmod.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_exptmod.c */ @@ -2938,9 +2938,9 @@ LBL_M: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_exptmod_fast.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_exptmod_fast.c */ @@ -3024,9 +3024,9 @@ _ERR: mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_exteuclid.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_exteuclid.c */ @@ -3095,9 +3095,9 @@ int mp_fread(mp_int *a, int radix, FILE *stream) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_fread.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_fread.c */ @@ -3151,9 +3151,9 @@ int mp_fwrite(mp_int *a, int radix, FILE *stream) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_fwrite.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_fwrite.c */ @@ -3260,9 +3260,9 @@ LBL_U:mp_clear (&v); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_gcd.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_gcd.c */ @@ -3309,9 +3309,9 @@ unsigned long mp_get_int(mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_get_int.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_get_int.c */ @@ -3370,9 +3370,9 @@ int mp_grow (mp_int * a, int size) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_grow.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_grow.c */ @@ -3420,9 +3420,9 @@ int mp_init (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_init.c */ @@ -3456,9 +3456,9 @@ int mp_init_copy (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init_copy.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_init_copy.c */ @@ -3519,9 +3519,9 @@ int mp_init_multi(mp_int *mp, ...) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init_multi.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_init_multi.c */ @@ -3555,9 +3555,9 @@ int mp_init_set (mp_int * a, mp_digit b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init_set.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_init_set.c */ @@ -3590,9 +3590,9 @@ int mp_init_set_int (mp_int * a, unsigned long b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init_set_int.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_init_set_int.c */ @@ -3642,9 +3642,9 @@ int mp_init_size (mp_int * a, int size) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_init_size.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_init_size.c */ @@ -3689,9 +3689,9 @@ int mp_invmod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_invmod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_invmod.c */ @@ -3868,9 +3868,9 @@ LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_invmod_slow.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_invmod_slow.c */ @@ -3981,9 +3981,9 @@ ERR:mp_clear(&t); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_is_square.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_is_square.c */ @@ -4090,9 +4090,9 @@ LBL_A1:mp_clear (&a1); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_jacobi.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_jacobi.c */ @@ -4261,9 +4261,9 @@ ERR: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_karatsuba_mul.c,v $ */ -/* $Revision: 1.6 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_karatsuba_mul.c */ @@ -4386,9 +4386,9 @@ ERR: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_karatsuba_sqr.c,v $ */ -/* $Revision: 1.6 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_karatsuba_sqr.c */ @@ -4450,9 +4450,9 @@ LBL_T: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_lcm.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_lcm.c */ @@ -4521,9 +4521,9 @@ int mp_lshd (mp_int * a, int b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_lshd.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_lshd.c */ @@ -4573,9 +4573,9 @@ mp_mod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_mod.c */ @@ -4632,9 +4632,9 @@ mp_mod_2d (mp_int * a, int b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mod_2d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_mod_2d.c */ @@ -4663,9 +4663,9 @@ mp_mod_d (mp_int * a, mp_digit b, mp_digit * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mod_d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_mod_d.c */ @@ -4726,9 +4726,9 @@ int mp_montgomery_calc_normalization (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_calc_normalization.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_montgomery_calc_normalization.c */ @@ -4848,9 +4848,9 @@ mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_reduce.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_montgomery_reduce.c */ @@ -4911,9 +4911,9 @@ mp_montgomery_setup (mp_int * n, mp_digit * rho) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_setup.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_montgomery_setup.c */ @@ -4981,9 +4981,9 @@ int mp_mul (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mul.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_mul.c */ @@ -5067,9 +5067,9 @@ int mp_mul_2(mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mul_2.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_mul_2.c */ @@ -5156,9 +5156,9 @@ int mp_mul_2d (mp_int * a, int b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mul_2d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_mul_2d.c */ @@ -5239,9 +5239,9 @@ mp_mul_d (mp_int * a, mp_digit b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mul_d.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_mul_d.c */ @@ -5283,9 +5283,9 @@ int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_mulmod.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_mulmod.c */ @@ -5419,9 +5419,9 @@ LBL_T1:mp_clear (&t1); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_n_root.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_n_root.c */ @@ -5463,9 +5463,9 @@ int mp_neg (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_neg.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_neg.c */ @@ -5517,9 +5517,9 @@ int mp_or (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_or.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_or.c */ @@ -5583,9 +5583,9 @@ LBL_T:mp_clear (&t); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_fermat.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_prime_fermat.c */ @@ -5637,9 +5637,9 @@ int mp_prime_is_divisible (mp_int * a, int *result) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_is_divisible.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_prime_is_divisible.c */ @@ -5724,9 +5724,9 @@ LBL_B:mp_clear (&b); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_is_prime.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_prime_is_prime.c */ @@ -5831,9 +5831,9 @@ LBL_N1:mp_clear (&n1); } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_miller_rabin.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_prime_miller_rabin.c */ @@ -5983,7 +5983,7 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style) /* is this prime? */ for (x = 0; x < t; x++) { - mp_set(&b, ltm_prime_tab[t]); + mp_set(&b, ltm_prime_tab[x]); if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) { goto LBL_ERR; } @@ -6005,9 +6005,9 @@ LBL_ERR: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_next_prime.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: v0.42.0 $ */ +/* $Date: 2010-07-15 13:49:00 +0000 $ */ /* End: bn_mp_prime_next_prime.c */ @@ -6061,9 +6061,9 @@ int mp_prime_rabin_miller_trials(int size) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_rabin_miller_trials.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_prime_rabin_miller_trials.c */ @@ -6190,9 +6190,9 @@ error: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_prime_random_ex.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_prime_random_ex.c */ @@ -6272,9 +6272,9 @@ int mp_radix_size (mp_int * a, int radix, int *size) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_radix_size.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_radix_size.c */ @@ -6300,9 +6300,9 @@ int mp_radix_size (mp_int * a, int radix, int *size) const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_radix_smap.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_radix_smap.c */ @@ -6359,9 +6359,9 @@ mp_rand (mp_int * a, int digits) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_rand.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_rand.c */ @@ -6448,9 +6448,9 @@ int mp_read_radix (mp_int * a, const char *str, int radix) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_read_radix.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_read_radix.c */ @@ -6493,9 +6493,9 @@ int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_read_signed_bin.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_read_signed_bin.c */ @@ -6552,9 +6552,9 @@ int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_read_unsigned_bin.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_read_unsigned_bin.c */ @@ -6656,9 +6656,9 @@ CLEANUP: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_reduce.c */ @@ -6721,9 +6721,9 @@ ERR: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_reduce_2k.c */ @@ -6787,9 +6787,9 @@ ERR: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_l.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_reduce_2k_l.c */ @@ -6838,9 +6838,9 @@ int mp_reduce_2k_setup(mp_int *a, mp_digit *d) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_setup.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_reduce_2k_setup.c */ @@ -6886,9 +6886,9 @@ ERR: } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_setup_l.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_reduce_2k_setup_l.c */ @@ -6942,9 +6942,9 @@ int mp_reduce_is_2k(mp_int *a) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_is_2k.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_reduce_is_2k.c */ @@ -6990,9 +6990,9 @@ int mp_reduce_is_2k_l(mp_int *a) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_is_2k_l.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_reduce_is_2k_l.c */ @@ -7028,9 +7028,9 @@ int mp_reduce_setup (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_setup.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_reduce_setup.c */ @@ -7104,9 +7104,9 @@ void mp_rshd (mp_int * a, int b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_rshd.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_rshd.c */ @@ -7137,9 +7137,9 @@ void mp_set (mp_int * a, mp_digit b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_set.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_set.c */ @@ -7189,9 +7189,9 @@ int mp_set_int (mp_int * a, unsigned long b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_set_int.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_set_int.c */ @@ -7217,20 +7217,25 @@ int mp_set_int (mp_int * a, unsigned long b) int mp_shrink (mp_int * a) { mp_digit *tmp; - if (a->alloc != a->used && a->used > 0) { - if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * a->used)) == NULL) { + int used = 1; + + if(a->used > 0) + used = a->used; + + if (a->alloc != used) { + if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * used)) == NULL) { return MP_MEM; } a->dp = tmp; - a->alloc = a->used; + a->alloc = used; } return MP_OKAY; } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_shrink.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: v0.42.0 $ */ +/* $Date: 2010-06-02 15:09:36 +0200 $ */ /* End: bn_mp_shrink.c */ @@ -7259,9 +7264,9 @@ int mp_signed_bin_size (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_signed_bin_size.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_signed_bin_size.c */ @@ -7321,9 +7326,9 @@ if (a->used >= KARATSUBA_SQR_CUTOFF) { } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_sqr.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_sqr.c */ @@ -7366,9 +7371,9 @@ mp_sqrmod (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_sqrmod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_sqrmod.c */ @@ -7451,9 +7456,9 @@ E2: mp_clear(&t1); #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_sqrt.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_sqrt.c */ @@ -7514,9 +7519,9 @@ mp_sub (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_sub.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_sub.c */ @@ -7611,9 +7616,9 @@ mp_sub_d (mp_int * a, mp_digit b, mp_int * c) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_sub_d.c,v $ */ -/* $Revision: 1.6 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_sub_d.c */ @@ -7657,9 +7662,9 @@ mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_submod.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_submod.c */ @@ -7694,9 +7699,9 @@ int mp_to_signed_bin (mp_int * a, unsigned char *b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_to_signed_bin.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_to_signed_bin.c */ @@ -7729,9 +7734,9 @@ int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_to_signed_bin_n.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_to_signed_bin_n.c */ @@ -7781,9 +7786,9 @@ int mp_to_unsigned_bin (mp_int * a, unsigned char *b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_to_unsigned_bin.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_to_unsigned_bin.c */ @@ -7816,9 +7821,9 @@ int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_to_unsigned_bin_n.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_to_unsigned_bin_n.c */ @@ -8104,9 +8109,9 @@ ERR: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_toom_mul.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_toom_mul.c */ @@ -8334,9 +8339,9 @@ ERR: #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_toom_sqr.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_toom_sqr.c */ @@ -8413,9 +8418,9 @@ int mp_toradix (mp_int * a, char *str, int radix) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_toradix.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_toradix.c */ @@ -8505,9 +8510,9 @@ int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen) #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_toradix_n.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_toradix_n.c */ @@ -8537,9 +8542,9 @@ int mp_unsigned_bin_size (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_unsigned_bin_size.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_unsigned_bin_size.c */ @@ -8592,9 +8597,9 @@ mp_xor (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_xor.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_xor.c */ @@ -8632,9 +8637,9 @@ void mp_zero (mp_int * a) } #endif -/* $Source: /cvs/libtom/libtommath/bn_mp_zero.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_mp_zero.c */ @@ -8697,9 +8702,9 @@ const mp_digit ltm_prime_tab[] = { }; #endif -/* $Source: /cvs/libtom/libtommath/bn_prime_tab.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_prime_tab.c */ @@ -8740,9 +8745,9 @@ bn_reverse (unsigned char *s, int len) } #endif -/* $Source: /cvs/libtom/libtommath/bn_reverse.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_reverse.c */ @@ -8853,9 +8858,9 @@ s_mp_add (mp_int * a, mp_int * b, mp_int * c) } #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_add.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_s_mp_add.c */ @@ -9109,9 +9114,9 @@ LBL_M: } #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_exptmod.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_s_mp_exptmod.c */ @@ -9203,9 +9208,9 @@ int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_mul_digs.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_s_mp_mul_digs.c */ @@ -9288,9 +9293,9 @@ s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) } #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_mul_high_digs.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_s_mp_mul_high_digs.c */ @@ -9376,9 +9381,9 @@ int s_mp_sqr (mp_int * a, mp_int * b) } #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_sqr.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_s_mp_sqr.c */ @@ -9469,9 +9474,9 @@ s_mp_sub (mp_int * a, mp_int * b, mp_int * c) #endif -/* $Source: /cvs/libtom/libtommath/bn_s_mp_sub.c,v $ */ -/* $Revision: 1.4 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bn_s_mp_sub.c */ @@ -9509,9 +9514,9 @@ int KARATSUBA_MUL_CUTOFF = 80, /* Min. number of digits before Karatsub TOOM_SQR_CUTOFF = 400; #endif -/* $Source: /cvs/libtom/libtommath/bncore.c,v $ */ -/* $Revision: 1.5 $ */ -/* $Date: 2006/12/28 01:25:13 $ */ +/* $Source$ */ +/* $Revision: 0.41 $ */ +/* $Date: 2007-04-18 09:58:18 +0000 $ */ /* End: bncore.c */ diff --git a/libtommath/tommath.h b/libtommath/tommath.h index 3c00b9e..cf9c499 100644 --- a/libtommath/tommath.h +++ b/libtommath/tommath.h @@ -579,6 +579,6 @@ extern const char *mp_s_rmap; #endif -/* $Source: /cvs/libtom/libtommath/tommath.h,v $ */ -/* $Revision: 1.8 $ */ -/* $Date: 2006/03/31 14:18:44 $ */ +/* $Source$ */ +/* $Revision: 0.39 $ */ +/* $Date: 2006-04-06 19:49:59 +0000 $ */ diff --git a/libtommath/tommath.pdf b/libtommath/tommath.pdf index 33994c3..0b68941 100644 Binary files a/libtommath/tommath.pdf and b/libtommath/tommath.pdf differ diff --git a/libtommath/tommath_class.h b/libtommath/tommath_class.h index 166dd80..1e29c8f 100644 --- a/libtommath/tommath_class.h +++ b/libtommath/tommath_class.h @@ -994,6 +994,6 @@ #define LTM_LAST #endif -/* $Source: /cvs/libtom/libtommath/tommath_class.h,v $ */ -/* $Revision: 1.3 $ */ -/* $Date: 2005/07/28 11:59:32 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ diff --git a/libtommath/tommath_superclass.h b/libtommath/tommath_superclass.h index 2fdebe6..89d5516 100644 --- a/libtommath/tommath_superclass.h +++ b/libtommath/tommath_superclass.h @@ -71,6 +71,6 @@ #endif -/* $Source: /cvs/libtom/libtommath/tommath_superclass.h,v $ */ -/* $Revision: 1.3 $ */ -/* $Date: 2005/05/14 13:29:17 $ */ +/* $Source$ */ +/* $Revision: 0.36 $ */ +/* $Date: 2005-08-01 16:37:28 +0000 $ */ -- cgit v0.12 From b30ba5a92be8e6597c0ff9e890d669f4d071d602 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Aug 2011 07:50:13 +0000 Subject: Upcoming TIP implementation: Full support for Unicode 6.0 --- generic/tcl.decls | 10 +- generic/tcl.h | 2 +- generic/tclBinary.c | 13 +- generic/tclCmdMZ.c | 22 ++- generic/tclDecls.h | 20 +-- generic/tclEncoding.c | 49 ++++-- generic/tclExecute.c | 2 +- generic/tclParse.c | 13 +- generic/tclScan.c | 16 +- generic/tclStringObj.c | 8 +- generic/tclUniData.c | 437 ++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclUtf.c | 258 ++++++++++++++++++++++------- tests/encoding.test | 9 +- tests/string.test | 8 +- tests/utf.test | 43 ++++- tools/uniParse.tcl | 40 +++-- 16 files changed, 795 insertions(+), 155 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 30a2aca..0d1dfdf 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1148,16 +1148,16 @@ declare 319 { Tcl_QueuePosition position) } declare 320 { - Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index) + int Tcl_UniCharAtIndex(const char *src, int index) } declare 321 { - Tcl_UniChar Tcl_UniCharToLower(int ch) + int Tcl_UniCharToLower(int ch) } declare 322 { - Tcl_UniChar Tcl_UniCharToTitle(int ch) + int Tcl_UniCharToTitle(int ch) } declare 323 { - Tcl_UniChar Tcl_UniCharToUpper(int ch) + int Tcl_UniCharToUpper(int ch) } declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) @@ -1351,7 +1351,7 @@ declare 380 { int Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 { - Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index) + int Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } declare 382 { Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) diff --git a/generic/tcl.h b/generic/tcl.h index 7370516..611e74e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2162,7 +2162,7 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 3 +#define TCL_UTF_MAX 4 #endif /* diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 0a340f2..6379fe8 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -425,7 +425,7 @@ SetByteArrayFromAny( const char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; if (objPtr->typePtr != &tclByteArrayType) { src = TclGetStringFromObj(objPtr, &length); @@ -433,8 +433,11 @@ SetByteArrayFromAny( byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += Tcl_UtfToUniChar(src, &ch); - *dst++ = UCHAR(ch); + int n = Tcl_UtfToUniChar(src, &ch); + if (n) { + src += n; + *dst++ = UCHAR(ch); + } } byteArrayPtr->used = dst - byteArrayPtr->bytes; @@ -1209,7 +1212,7 @@ BinaryFormatCmd( badField: { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; char buf[TCL_UTF_MAX + 1]; Tcl_UtfToUniChar(errorString, &ch); @@ -1578,7 +1581,7 @@ BinaryScanCmd( badField: { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; char buf[TCL_UTF_MAX + 1]; Tcl_UtfToUniChar(errorString, &ch); diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index e7c7152..42b2847 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -283,7 +283,7 @@ Tcl_RegexpObjCmd( */ if ((offset == 0) || ((offset > 0) && - (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar) '\n'))) { + (Tcl_GetUniChar(objPtr, offset-1) == '\n'))) { eflags = 0; } else { eflags = TCL_REG_NOTBOL; @@ -465,7 +465,7 @@ Tcl_RegsubObjCmd( Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; - Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; + Tcl_UniChar ch = 0, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; static const char *const options[] = { "-all", "-nocase", "-expanded", @@ -1011,7 +1011,7 @@ Tcl_SplitObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; int len; const char *splitChars; const char *stringPtr; @@ -1096,7 +1096,7 @@ Tcl_SplitObjCmd( } else { const char *element, *p, *splitEnd; int splitLen; - Tcl_UniChar splitChar; + Tcl_UniChar splitChar = 0; /* * Normal case: split on any of a given set of characters. Discard @@ -1425,7 +1425,7 @@ StringIsCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *end, *stop; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ int i, failat = 0, result = 1, strict = 0, index, length1, length2; Tcl_Obj *objPtr, *failVarObj = NULL; @@ -1710,8 +1710,14 @@ StringIsCmd( } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { + int fullchar; length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { + fullchar = ch; + if (!length2) { + length2 = TclUtfToUniChar(string1, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } + if (!chcomp(fullchar)) { result = 0; break; } @@ -2363,7 +2369,7 @@ StringStartCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; const char *p, *string; int cur, index, length, numChars; @@ -2424,7 +2430,7 @@ StringEndCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; const char *p, *end, *string; int cur, index, length, numChars; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1df7e14..54e426b 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -945,13 +945,13 @@ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 320 */ -EXTERN Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index); +EXTERN int Tcl_UniCharAtIndex(const char *src, int index); /* 321 */ -EXTERN Tcl_UniChar Tcl_UniCharToLower(int ch); +EXTERN int Tcl_UniCharToLower(int ch); /* 322 */ -EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch); +EXTERN int Tcl_UniCharToTitle(int ch); /* 323 */ -EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch); +EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ @@ -1103,7 +1103,7 @@ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index); +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index); /* 382 */ EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ @@ -2162,10 +2162,10 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */ - Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ - Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */ - Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */ - Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */ + int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ + int (*tcl_UniCharToLower) (int ch); /* 321 */ + int (*tcl_UniCharToTitle) (int ch); /* 322 */ + int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */ @@ -2223,7 +2223,7 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ - Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 15411d8..987d2ae 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2261,8 +2261,11 @@ UtfToUtfProc( const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd; int result, numChars; - Tcl_UniChar ch; + Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + if (flags & TCL_ENCODING_START) { + *chPtr = 0; + } result = TCL_OK; srcStart = src; @@ -2311,12 +2314,14 @@ UtfToUtfProc( * incomplete char its byts are made to represent themselves. */ - ch = (unsigned char) *src; + *chPtr = (unsigned char) *src; src += 1; - dst += Tcl_UniCharToUtf(ch, dst); + dst += Tcl_UniCharToUtf(*chPtr, dst); } else { - src += Tcl_UtfToUniChar(src, &ch); - dst += Tcl_UniCharToUtf(ch, dst); + int n = Tcl_UtfToUniChar(src, chPtr); + src += n; + if (!n) numChars--; + dst += Tcl_UniCharToUtf(*chPtr, dst); } } @@ -2372,8 +2377,11 @@ UnicodeToUtfProc( const char *srcStart, *srcEnd; const char *dstEnd, *dstStart; int result, numChars; - Tcl_UniChar ch; + Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + if (flags & TCL_ENCODING_START) { + *chPtr = 0; + } result = TCL_OK; if ((srcLen % sizeof(Tcl_UniChar)) != 0) { result = TCL_CONVERT_MULTIBYTE; @@ -2398,11 +2406,13 @@ UnicodeToUtfProc( * Tcl_UniChar-size data. */ - ch = *(Tcl_UniChar *)src; - if (ch && ch < 0x80) { - *dst++ = (ch & 0xFF); + *chPtr = *(Tcl_UniChar *)src; + if (*chPtr && *chPtr < 0x80) { + *dst++ = (*chPtr & 0xFF); } else { - dst += Tcl_UniCharToUtf(ch, dst); + int n = Tcl_UniCharToUtf(*chPtr, dst); + dst += n; + if (!n) --numChars;/* Don't count high surrogates */ } src += sizeof(Tcl_UniChar); } @@ -2459,8 +2469,11 @@ UtfToUnicodeProc( { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; - Tcl_UniChar ch; + Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + if (flags & TCL_ENCODING_START) { + *chPtr = 0; + } srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2486,7 +2499,7 @@ UtfToUnicodeProc( result = TCL_CONVERT_NOSPACE; break; } - src += TclUtfToUniChar(src, &ch); + src += TclUtfToUniChar(src, chPtr); /* * Need to handle this in a way that won't cause misalignment by @@ -2495,11 +2508,11 @@ UtfToUnicodeProc( */ #ifdef WORDS_BIGENDIAN - *dst++ = (ch >> 8); - *dst++ = (ch & 0xFF); + *dst++ = (*chPtr >> 8); + *dst++ = (*chPtr & 0xFF); #else - *dst++ = (ch & 0xFF); - *dst++ = (ch >> 8); + *dst++ = (*chPtr & 0xFF); + *dst++ = (*chPtr >> 8); #endif } *srcReadPtr = src - srcStart; @@ -2556,7 +2569,7 @@ TableToUtfProc( const char *srcStart, *srcEnd; const char *dstEnd, *dstStart, *prefixBytes; int result, byte, numChars; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; const unsigned short *const *toUnicode; const unsigned short *pageZero; TableEncodingData *dataPtr = clientData; @@ -2665,7 +2678,7 @@ TableFromUtfProc( { const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd, *prefixBytes; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; int result, len, word, numChars; TableEncodingData *dataPtr = clientData; const unsigned short *const *fromUnicode; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 691c8d7..2df935b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4557,7 +4557,7 @@ TEBCresume( valuePtr->bytes+index, 1); } else { char buf[TCL_UTF_MAX]; - Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index); + int ch = Tcl_GetUniChar(valuePtr, index); /* * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) diff --git a/generic/tclParse.c b/generic/tclParse.c index 3c984bf..66a1575 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -808,7 +808,7 @@ TclParseBackslash( * written there. */ { register const char *p = src+1; - Tcl_UniChar unichar; + Tcl_UniChar unichar = 0; int result; int count; char buf[TCL_UTF_MAX]; @@ -958,6 +958,15 @@ TclParseBackslash( if (readPtr != NULL) { *readPtr = count; } + if ((result & 0xF800) == 0xD800) { + /* If result is a surrogate, Tcl_UniCharToUtf will try to + * handle that especially, but we don't want that here. + */ + dst[2] = (char) ((result | 0x80) & 0xBF); + dst[1] = (char) (((result >> 6) | 0x80) & 0xBF); + dst[0] = (char) ((result >> 12) | 0xE0); + return 3; + } return Tcl_UniCharToUtf(result, dst); } @@ -1356,7 +1365,7 @@ Tcl_ParseVarName( register const char *src; unsigned char c; int varIndex, offset; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; unsigned array; if ((numBytes == 0) || (start == NULL)) { diff --git a/generic/tclScan.c b/generic/tclScan.c index d21bfaf..0a6f49f 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -72,7 +72,7 @@ BuildCharSet( CharSet *cset, const char *format) /* Points to first char of set. */ { - Tcl_UniChar ch, start; + Tcl_UniChar ch = 0, start; int offset, nranges; const char *end; @@ -257,7 +257,7 @@ ValidateFormat( { int gotXpg, gotSequential, value, i, flags; char *end; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; int objIndex, xpgSize, nspace = numVars; int *nassign = TclStackAlloc(interp, nspace * sizeof(int)); char buf[TCL_UTF_MAX+1]; @@ -570,7 +570,7 @@ Tcl_ScanObjCmd( char op = 0; int width, underflow = 0; Tcl_WideInt wideValue; - Tcl_UniChar ch, sch; + Tcl_UniChar ch = 0, sch = 0; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; char buf[513]; /* Temporary buffer to hold scanned number @@ -870,9 +870,15 @@ Tcl_ScanObjCmd( * Scan a single Unicode character. */ - string += Tcl_UtfToUniChar(string, &sch); + offset = Tcl_UtfToUniChar(string, &sch); + i = (int)sch; + if (!offset) { + offset = Tcl_UtfToUniChar(string, &sch); + i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); + } + string += offset; if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj((int)sch); + objPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 993a694..5838c0f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -531,7 +531,7 @@ Tcl_GetCharLength( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_GetUniChar( Tcl_Obj *objPtr, /* The object to get the Unicode charater * from. */ @@ -548,7 +548,7 @@ Tcl_GetUniChar( if (TclIsPureByteArray(objPtr)) { unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); - return (Tcl_UniChar) bytes[index]; + return (int) bytes[index]; } /* @@ -572,7 +572,7 @@ Tcl_GetUniChar( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - return stringPtr->unicode[index]; + return (int) stringPtr->unicode[index]; } /* @@ -1708,6 +1708,7 @@ Tcl_AppendFormatToObj( const char *span = format, *msg, *errCode; int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0; int originalLength, limit; + Tcl_UniChar ch = 0; static const char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers"; static const char *const badIndex[2] = { @@ -1732,7 +1733,6 @@ Tcl_AppendFormatToObj( int width, gotPrecision, precision, useShort, useWide, useBig; int newXpg, numChars, allocSegment = 0, segmentLimit, segmentNumBytes; Tcl_Obj *segment; - Tcl_UniChar ch; int step = Tcl_UtfToUniChar(format, &ch); format += step; diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 6cff83a..c5343da 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -151,7 +151,247 @@ static const unsigned short pageMap[] = { 42, 42, 291, 42, 291, 42, 42, 292, 56, 293, 294, 295, 42, 42, 296, 297, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 298, 299, 42, 300, 42, 301, 302, 303, 304, 305, 306, 42, 42, 42, 307, 308, 2, 309, 310, 311, - 312, 313, 314 + 312, 313, 314, 315, 316, 317, 56, 42, 42, 42, 247, 318, 319, 320, 321, + 322, 56, 323, 324, 56, 56, 56, 56, 140, 42, 325, 56, 312, 326, 327, + 56, 328, 42, 329, 56, 330, 331, 332, 42, 333, 334, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 335, 336, 337, 56, 56, 56, 56, 56, 338, 339, 56, + 56, 56, 56, 56, 56, 340, 341, 342, 343, 56, 56, 56, 56, 42, 344, 345, + 346, 56, 56, 56, 56, 42, 42, 347, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 348, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 349, 350, 351, 352, 156, 353, 354, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 355, 56, 56, 56, 56, 320, 320, 320, 356, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 355, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 357, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 358, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 146, 146, 146, 146, + 146, 146, 146, 238, 146, 359, 146, 360, 361, 362, 363, 56, 146, 146, + 364, 56, 56, 56, 56, 56, 146, 146, 365, 366, 56, 56, 56, 56, 367, 368, + 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 367, 368, 380, + 370, 381, 382, 383, 374, 384, 385, 386, 387, 388, 389, 390, 391, 392, + 393, 394, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 146, 395, 146, 146, 237, 396, 397, 56, + 398, 399, 146, 400, 401, 56, 56, 402, 403, 401, 404, 56, 56, 56, 56, + 56, 146, 405, 146, 406, 237, 146, 407, 408, 146, 249, 409, 146, 146, + 146, 146, 410, 146, 363, 323, 411, 56, 56, 56, 412, 413, 414, 415, + 56, 146, 146, 416, 56, 146, 146, 146, 237, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 232, 56, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 123, 42, 42, + 42, 42, 42, 42, 333, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 333 }; /* @@ -723,7 +963,189 @@ static const unsigned char groupMap[] = { 46, 46, 46, 46, 46, 46, 0, 0, 46, 46, 46, 46, 46, 46, 0, 0, 46, 46, 46, 46, 46, 46, 0, 0, 46, 46, 46, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14, 7, 7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, - 14, 0, 0 + 14, 0, 0, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 0, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 0, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 0, 46, 46, 0, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 0, 0, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 0, 0, 3, 3, 14, 0, 0, 0, 0, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, + 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, + 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, + 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, + 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 18, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 85, 0, 0, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 117, 46, 46, 46, 46, 46, 46, 46, 46, 117, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 0, 3, 46, 46, 46, 46, 0, 0, + 0, 0, 46, 46, 46, 46, 46, 46, 46, 46, 3, 117, 117, 117, 117, 117, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 166, 166, 166, 166, 166, 166, 166, 166, + 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, + 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, + 166, 166, 166, 166, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, + 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, + 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, + 167, 167, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 0, 0, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 46, 46, 46, 46, 46, 46, 0, 0, 46, 0, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 0, 46, 46, 0, 0, 0, 46, 0, 0, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 0, 3, 18, 18, 18, 18, 18, 18, 18, 18, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 18, 18, 18, 18, 18, 18, 0, 0, 0, 3, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 0, 0, 0, 0, 0, 3, 46, 85, 85, 85, 0, 85, 85, 0, 0, 0, 0, 0, 85, + 85, 85, 85, 46, 46, 46, 46, 0, 46, 46, 46, 0, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 0, 0, 0, 0, 85, 85, 85, 0, 0, 0, 0, 85, 18, 18, 18, + 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 18, 18, 3, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 0, 0, 0, + 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 115, + 85, 115, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 115, 115, + 115, 85, 85, 85, 85, 115, 115, 85, 85, 3, 3, 17, 3, 3, 3, 3, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 117, 117, + 117, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, + 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 0, 0, 0, 0, + 0, 0, 0, 46, 46, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 115, 115, 85, 85, 85, + 14, 14, 14, 115, 115, 115, 115, 115, 115, 17, 17, 17, 17, 17, 17, 17, + 17, 85, 85, 85, 85, 85, 85, 85, 85, 14, 14, 85, 85, 85, 85, 85, 85, + 85, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 85, 85, 85, + 85, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, + 14, 85, 85, 85, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 99, 0, 99, 99, 0, 0, 99, 0, 0, 99, 99, 0, 0, 99, 99, 99, 99, 0, 99, + 99, 99, 99, 99, 99, 99, 99, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, + 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 99, + 99, 0, 99, 99, 99, 99, 0, 0, 99, 99, 99, 99, 99, 99, 99, 99, 0, 99, + 99, 99, 99, 99, 99, 99, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 99, + 99, 0, 99, 99, 99, 99, 0, 99, 99, 99, 99, 99, 0, 99, 0, 0, 0, 99, 99, + 99, 99, 99, 99, 99, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 99, 99, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 15, 15, 15, 15, 15, 15, 0, 0, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 7, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 7, 15, + 15, 15, 15, 15, 15, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 7, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 7, 15, 15, 15, 15, 15, 15, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 7, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 7, 15, 15, 15, 15, + 15, 15, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 7, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 7, 15, 15, 15, 15, 15, 15, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 7, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 7, 15, 15, 15, 15, 15, 15, 99, + 15, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, + 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, + 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 0, + 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 0, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 0, 14, 0, 14, + 0, 14, 0, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, + 14, 0, 14, 0, 0, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, + 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0 }; /* @@ -767,7 +1189,7 @@ static const int groups[] = { 13, 14, -246316991, -274694079, -270729151, 917569, 917634, 524362, 524426, 852061, 852125, -352026559, -124977087, -351502271, 353730690, 353632386, -353238975, -352223167, -353337279, -353304511, -354385855, - 238026882, -1157758911, -1385430975, 18, 17 + 238026882, -1157758911, -1385430975, 18, 17, 1310785, 1310850 }; /* @@ -775,7 +1197,8 @@ static const int groups[] = { * Unicode character. */ -#define UNICODE_CATEGORY_MASK 0X1F +#define UNICODE_CATEGORY_MASK 0x1F +#define UNICODE_OUT_OF_RANGE 0x2FA20u enum { UNASSIGNED, @@ -817,13 +1240,13 @@ enum { */ #define GetCaseType(info) (((info) & 0xE0) >> 5) -#define GetCategory(info) ((info) & 0x1F) +#define GetCategory(ch) (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) #define GetDelta(info) (((info) > 0) ? ((info) >> 15) : (~(~((info)) >> 15))) /* * This macro extracts the information about a character from the - * Unicode character tables. + * Unicode character tables. It may only be used for (unsigned) ch < UNICODE_OUT_OF_RANGE */ -#define GetUniCharInfo(ch) (groups[groupMap[(pageMap[(((int)(ch)) & 0xffff) >> OFFSET_BITS] << OFFSET_BITS) | ((ch) & ((1 << OFFSET_BITS)-1))]]) +#define GetUniCharInfo(ch) (groups[groupMap[(pageMap[((int)(ch)) >> OFFSET_BITS] << OFFSET_BITS) | ((ch) & ((1 << OFFSET_BITS)-1))]]) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index ab26779..5819bcd 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -122,6 +122,11 @@ UtfCount( return 3; } #if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX == 4 + if (ch <= 0x10FFFF) { + return 4; + } +#else if (ch <= 0x1FFFFF) { return 4; } @@ -132,6 +137,7 @@ UtfCount( return 6; } #endif +#endif return 3; } @@ -173,6 +179,23 @@ Tcl_UniCharToUtf( return 2; } if (ch <= 0xFFFF) { +#if TCL_UTF_MAX == 4 + if ((ch & 0xF800) == 0xD800) { + if (ch & 0x0400) { + /* Low surrogate */ + buf[3] = (char) ((ch | 0x80) & 0xBF); + buf[2] |= (char) (((ch >> 6) | 0x80) & 0x8F); + return 4; + } else { + /* High surrogate */ + ch += 0x40; + buf[2] = (char) (((ch << 4) | 0x80) & 0xB0); + buf[1] = (char) (((ch >> 2) | 0x80) & 0xBF); + buf[0] = (char) (((ch >> 8) | 0xF0) & 0xF7); + return 0; + } + } +#endif three: buf[2] = (char) ((ch | 0x80) & 0xBF); buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF); @@ -181,6 +204,15 @@ Tcl_UniCharToUtf( } #if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX == 4 + if (ch <= 0x10FFFF) { + buf[3] = (char) ((ch | 0x80) & 0xBF); + buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); + buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF); + buf[0] = (char) ((ch >> 18) | 0xF0); + return 4; + } +#else if (ch <= 0x1FFFFF) { buf[3] = (char) ((ch | 0x80) & 0xBF); buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); @@ -206,6 +238,7 @@ Tcl_UniCharToUtf( return 6; } #endif +#endif } ch = 0xFFFD; @@ -282,6 +315,16 @@ Tcl_UniCharToUtfDString( * *chPtr is filled with the Tcl_UniChar, and the return value is the * number of bytes from the UTF-8 string that were consumed. * + * If TCL_UTF_MAX == 4, special handling of Surrogate pairs is done: + * + * If the UTF-8 string represents a character outside of the BMP, the + * first call to this function will fill *chPtr with the high surrogate + * and generate a return value of 0. Calling Tcl_UtfToUniChar again + * will produce the low surrogate and a return value of 4. Because *chPtr + * is used to remember whether the high surrogate is already produced, it + * is recommended to initialize the variable it points to as 0 before + * the first call to Tcl_UtfToUniChar is done. + * * Side effects: * None. * @@ -345,8 +388,40 @@ Tcl_UtfToUniChar( *chPtr = (Tcl_UniChar) byte; return 1; +#if TCL_UTF_MAX == 4 + } else if (byte < 0xF8) { + if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) { + Tcl_UniChar surrogate; + /* + * Four-byte-character lead byte followed by three trail bytes. + */ + + byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) + | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)) - 0x10000; + surrogate = 0xD800 + (byte >> 10); + if (byte & 0x100000) { + /* out of range, < 0x10000 or > 0x10ffff */ + } else if (*chPtr != surrogate) { + /* produce high surrogate, but don't advance source pointer */ + *chPtr = surrogate; + return 0; + } else { + /* produce low surrogate, and advance source pointer */ + *chPtr = (Tcl_UniChar) (0xDC00 | (byte & 0x3FF)); + return 4; + } + } + + /* + * A four-byte-character lead-byte not followed by three trail-bytes + * or representing a character < 0x10000 or > 0x10ffff represents itself. + */ + + *chPtr = (Tcl_UniChar) byte; + return 1; +#endif } -#if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX > 4 { int ch, total, trail; @@ -401,7 +476,7 @@ Tcl_UtfToUniCharDString( * appended to this previously initialized * DString. */ { - Tcl_UniChar *w, *wString; + Tcl_UniChar ch, *w, *wString; const char *p, *end; int oldLength; @@ -423,8 +498,8 @@ Tcl_UtfToUniCharDString( w = wString; end = src + length; for (p = src; p < end; ) { - p += TclUtfToUniChar(p, w); - w++; + p += TclUtfToUniChar(p, &ch); + *w++ = ch; } *w = '\0'; Tcl_DStringSetLength(dsPtr, @@ -488,7 +563,7 @@ Tcl_NumUtfChars( int length) /* The length of the string in bytes, or -1 * for strlen(string). */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; register Tcl_UniChar *chPtr = &ch; register int i; @@ -548,7 +623,7 @@ Tcl_UtfFindFirst( int ch) /* The Tcl_UniChar to search for. */ { int len; - Tcl_UniChar find; + Tcl_UniChar find = 0; while (1) { len = TclUtfToUniChar(src, &find); @@ -587,7 +662,7 @@ Tcl_UtfFindLast( int ch) /* The Tcl_UniChar to search for. */ { int len; - Tcl_UniChar find; + Tcl_UniChar find = 0; const char *last; last = NULL; @@ -627,8 +702,7 @@ const char * Tcl_UtfNext( const char *src) /* The current location in the string. */ { - Tcl_UniChar ch; - + Tcl_UniChar ch = 0; return src + TclUtfToUniChar(src, &ch); } @@ -700,16 +774,25 @@ Tcl_UtfPrev( *--------------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharAtIndex( register const char *src, /* The UTF-8 string to dereference. */ register int index) /* The position of the desired character. */ { - Tcl_UniChar ch = 0; - - while (index >= 0) { - index--; - src += TclUtfToUniChar(src, &ch); + Tcl_UniChar unichar = 0; + int bytes; + int ch = 0; + + while (index-- >= 0) { + bytes = TclUtfToUniChar(src, &unichar); + ch = unichar; + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &unichar); + /* Combine surrogates */ + ch = (((ch & 0x3ff) << 10) | (unichar & 0x3ff)) + 0x10000; + } + src += bytes; } return ch; } @@ -736,11 +819,16 @@ Tcl_UtfAtIndex( register const char *src, /* The UTF-8 string. */ register int index) /* The position of the desired character. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; + int len; while (index > 0) { - index--; - src += TclUtfToUniChar(src, &ch); + index--; + len = TclUtfToUniChar(src, &ch); + if (!len) { + len = TclUtfToUniChar(src, &ch); + } + src += len; } return src; } @@ -820,7 +908,8 @@ int Tcl_UtfToUpper( char *str) /* String to convert in place. */ { - Tcl_UniChar ch, upChar; + Tcl_UniChar ch = 0; + int upChar; char *src, *dst; int bytes; @@ -831,7 +920,14 @@ Tcl_UtfToUpper( src = dst = str; while (*src) { bytes = TclUtfToUniChar(src, &ch); - upChar = Tcl_UniCharToUpper(ch); + upChar = ch; + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + upChar = (((upChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } + upChar = Tcl_UniCharToUpper(upChar); /* * To keep badly formed Utf strings from getting inflated by the @@ -873,7 +969,8 @@ int Tcl_UtfToLower( char *str) /* String to convert in place. */ { - Tcl_UniChar ch, lowChar; + Tcl_UniChar ch = 0; + int lowChar; char *src, *dst; int bytes; @@ -884,7 +981,14 @@ Tcl_UtfToLower( src = dst = str; while (*src) { bytes = TclUtfToUniChar(src, &ch); - lowChar = Tcl_UniCharToLower(ch); + lowChar = ch; + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } + lowChar = Tcl_UniCharToLower(lowChar); /* * To keep badly formed Utf strings from getting inflated by the @@ -927,7 +1031,8 @@ int Tcl_UtfToTitle( char *str) /* String to convert in place. */ { - Tcl_UniChar ch, titleChar, lowChar; + Tcl_UniChar ch = 0; + int titleChar, lowChar; char *src, *dst; int bytes; @@ -940,7 +1045,14 @@ Tcl_UtfToTitle( if (*src) { bytes = TclUtfToUniChar(src, &ch); - titleChar = Tcl_UniCharToTitle(ch); + titleChar = ch; + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } + titleChar = Tcl_UniCharToTitle(titleChar); if (bytes < UtfCount(titleChar)) { memcpy(dst, src, (size_t) bytes); @@ -952,7 +1064,14 @@ Tcl_UtfToTitle( } while (*src) { bytes = TclUtfToUniChar(src, &ch); - lowChar = Tcl_UniCharToLower(ch); + lowChar = ch; + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } + lowChar = Tcl_UniCharToLower(lowChar); if (bytes < UtfCount(lowChar)) { memcpy(dst, src, (size_t) bytes); @@ -1036,7 +1155,7 @@ Tcl_UtfNcmp( const char *ct, /* UTF string cs is compared to. */ unsigned long numChars) /* Number of UTF chars to compare. */ { - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; /* * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the @@ -1084,7 +1203,7 @@ Tcl_UtfNcasecmp( const char *ct, /* UTF string cs is compared to. */ unsigned long numChars) /* Number of UTF chars to compare. */ { - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. @@ -1120,14 +1239,14 @@ Tcl_UtfNcasecmp( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToUpper( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); + int info = (ch < UNICODE_OUT_OF_RANGE) ? GetUniCharInfo(ch) : 0; if (GetCaseType(info) & 0x04) { - return (Tcl_UniChar) (ch - GetDelta(info)); + return ch - GetDelta(info); } else { return ch; } @@ -1149,14 +1268,14 @@ Tcl_UniCharToUpper( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToLower( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); + int info = (ch < UNICODE_OUT_OF_RANGE) ? GetUniCharInfo(ch) : 0; if (GetCaseType(info) & 0x02) { - return (Tcl_UniChar) (ch + GetDelta(info)); + return ch + GetDelta(info); } else { return ch; } @@ -1178,11 +1297,11 @@ Tcl_UniCharToLower( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToTitle( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); + int info = (ch < UNICODE_OUT_OF_RANGE) ? GetUniCharInfo(ch) : 0; int mode = GetCaseType(info); if (mode & 0x1) { @@ -1192,7 +1311,7 @@ Tcl_UniCharToTitle( return (Tcl_UniChar) (ch + ((mode & 0x4) ? -1 : 1)); } else if (mode == 0x4) { - return (Tcl_UniChar) (ch - GetDelta(info)); + return ch - GetDelta(info); } else { return ch; } @@ -1329,9 +1448,10 @@ int Tcl_UniCharIsAlnum( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - - return (((ALPHA_BITS | DIGIT_BITS) >> category) & 1); + if (ch > UNICODE_OUT_OF_RANGE) { + return 0; + } + return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1); } /* @@ -1354,8 +1474,10 @@ int Tcl_UniCharIsAlpha( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - return ((ALPHA_BITS >> category) & 1); + if (ch > UNICODE_OUT_OF_RANGE) { + return 0; + } + return ((ALPHA_BITS >> GetCategory(ch)) & 1); } /* @@ -1378,7 +1500,10 @@ int Tcl_UniCharIsControl( int ch) /* Unicode character to test. */ { - return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == CONTROL); + if (ch > UNICODE_OUT_OF_RANGE) { + return 0; + } + return (GetCategory(ch) == CONTROL); } /* @@ -1401,7 +1526,10 @@ int Tcl_UniCharIsDigit( int ch) /* Unicode character to test. */ { - return (GetUniCharInfo(ch)&UNICODE_CATEGORY_MASK) == DECIMAL_DIGIT_NUMBER; + if (ch > UNICODE_OUT_OF_RANGE) { + return 0; + } + return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER); } /* @@ -1424,8 +1552,10 @@ int Tcl_UniCharIsGraph( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - return (((PRINT_BITS >> category) & 1) && ((unsigned char) ch != ' ')); + if ((ch == ' ') || (ch > UNICODE_OUT_OF_RANGE)) { + return (ch >= 0xE0100u) && (ch <= 0xE01EFu); + } + return ((PRINT_BITS >> GetCategory(ch)) & 1); } /* @@ -1448,7 +1578,10 @@ int Tcl_UniCharIsLower( int ch) /* Unicode character to test. */ { - return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == LOWERCASE_LETTER); + if (ch > UNICODE_OUT_OF_RANGE) { + return 0; + } + return (GetCategory(ch) == LOWERCASE_LETTER); } /* @@ -1471,8 +1604,10 @@ int Tcl_UniCharIsPrint( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - return ((PRINT_BITS >> category) & 1); + if (ch > UNICODE_OUT_OF_RANGE) { + return (ch >= 0xE0100u) && (ch <= 0xE01EFu); + } + return ((PRINT_BITS >> GetCategory(ch)) & 1); } /* @@ -1495,8 +1630,10 @@ int Tcl_UniCharIsPunct( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - return ((PUNCT_BITS >> category) & 1); + if (ch > UNICODE_OUT_OF_RANGE) { + return 0; + } + return ((PUNCT_BITS >> GetCategory(ch)) & 1); } /* @@ -1519,8 +1656,6 @@ int Tcl_UniCharIsSpace( int ch) /* Unicode character to test. */ { - register int category; - /* * If the character is within the first 127 characters, just use the * standard C function, otherwise consult the Unicode table. @@ -1528,9 +1663,10 @@ Tcl_UniCharIsSpace( if (ch < 0x80) { return TclIsSpaceProc((char)ch); + } else if (ch > UNICODE_OUT_OF_RANGE) { + return 0; } else { - category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - return ((SPACE_BITS >> category) & 1); + return ((SPACE_BITS >> GetCategory(ch)) & 1); } } @@ -1554,7 +1690,10 @@ int Tcl_UniCharIsUpper( int ch) /* Unicode character to test. */ { - return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == UPPERCASE_LETTER); + if (ch > UNICODE_OUT_OF_RANGE) { + return 0; + } + return (GetCategory(ch) == UPPERCASE_LETTER); } /* @@ -1577,9 +1716,10 @@ int Tcl_UniCharIsWordChar( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - - return (((ALPHA_BITS | DIGIT_BITS | CONNECTOR_BITS) >> category) & 1); + if (ch > UNICODE_OUT_OF_RANGE) { + return 0; + } + return (((ALPHA_BITS | DIGIT_BITS | CONNECTOR_BITS) >> GetCategory(ch)) & 1); } /* @@ -1613,7 +1753,7 @@ Tcl_UniCharCaseMatch( * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { - Tcl_UniChar ch1, p; + Tcl_UniChar ch1 = 0, p; while (1) { p = *uniPattern; diff --git a/tests/encoding.test b/tests/encoding.test index a4f8449..d14d8f0 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -327,9 +327,14 @@ test encoding-16.1 {UnicodeToUtfProc} { set val [encoding convertfrom unicode NN] list $val [format %x [scan $val %c]] } "\u4e4e 4e4e" +test encoding-16.2 {UnicodeToUtfProc} -constraints utf16 -body { + set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"] + list $val [format %x [scan $val %c]] +} -result "\U460dc 460dc" -test encoding-17.1 {UtfToUnicodeProc} { -} {} +test encoding-17.1 {UtfToUnicodeProc} -constraints utf16 -body { + encoding convertto unicode "\U460dc" +} -result "\xd8\xd8\xdc\xdc" test encoding-18.1 {TableToUtfProc} { } {} diff --git a/tests/string.test b/tests/string.test index 1a62a66..73640bf 100644 --- a/tests/string.test +++ b/tests/string.test @@ -571,12 +571,12 @@ test string-6.85 {string is control} { } 0 test string-6.86 {string is graph} { ## graph is any print char, except space - list [string is gra -fail var "0123abc!@#\$\u0100 "] $var -} {0 12} + list [string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "] $var +} {0 14} test string-6.87 {string is print} { ## basically any printable char - list [string is print -fail var "0123abc!@#\$\u0100 \u0010"] $var -} {0 13} + list [string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"] $var +} {0 15} test string-6.88 {string is punct} { ## any graph char that isn't alnum list [string is punct -fail var "_!@#\u00beq0"] $var diff --git a/tests/utf.test b/tests/utf.test index 64b5cd4..04bf9f2 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -15,6 +15,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch {unset x} +# Some tests require support for utf16 + +testConstraint utf16 [expr {[format %c 0x010000] != [bytestring "\xef\xbf\xbd"]}] + test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { set x \x01 } [bytestring "\x01"] @@ -27,10 +31,13 @@ test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} { test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} { set x "\u4e4e" } [bytestring "\xe4\xb9\x8e"] -test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} { +test utf-1.5 {Tcl_UniCharToUtf: 4 byte sequences} -constraints utf16 -body { + set x "\U014e4e" +} -result [bytestring "\xf0\x94\xb9\x8e"] +test utf-1.6 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} { format %c 0x110000 } [bytestring "\xef\xbf\xbd"] -test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} { +test utf-1.7 {Tcl_UniCharToUtf: negative Tcl_UniChar} { format %c -1 } [bytestring "\xef\xbf\xbd"] @@ -55,9 +62,21 @@ test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} { test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} { string length [bytestring "\xE4\xb9\x8e"] } {1} -test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} { - string length [bytestring "\xF4\xA2\xA2\xA2"] +test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints utf16 -body { + string length [bytestring "\xF0\x90\x80\x80"] +} -result {1} +test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints utf16 -body { + string length [bytestring "\xF4\x8F\xBF\xBF"] +} -result {1} +test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} { + string length [bytestring "\xF0\x8F\xBF\xBF"] } {4} +test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} { + string length [bytestring "\xF4\x90\x80\x80"] +} {4} +test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} { + string length [bytestring "\xF8\xA2\xA2\xA2\xA2"] +} {5} test utf-3.1 {Tcl_UtfCharComplete} { } {} @@ -190,8 +209,16 @@ bsCheck \Ua1 161 bsCheck \U4e21 20001 bsCheck \U004e21 20001 bsCheck \U00004e21 20001 -bsCheck \U00110000 65533 -bsCheck \Uffffffff 65533 +bsCheck \U0000004e21 78 +if {[testConstraint utf16]} { + bsCheck \U00110000 69632 + bsCheck \U01100000 69632 + bsCheck \U11000000 69632 + bsCheck \U0010FFFF 1114111 + bsCheck \U010FFFF0 1114111 + bsCheck \U10FFFF00 1114111 + bsCheck \UFFFFFFFF 1048575 +} test utf-11.1 {Tcl_UtfToUpper} { string toupper {} @@ -259,8 +286,8 @@ test utf-16.1 {Tcl_UniCharToLower, negative delta} { string tolower aA } aa test utf-16.2 {Tcl_UniCharToLower, positive delta} { - string tolower \u0178\u00ff\uA78D -} \u00ff\u00ff\u0265 + string tolower \u0178\u00ff\uA78D\U10400 +} \u00ff\u00ff\u0265\U10428 test utf-17.1 {Tcl_UniCharToLower, no delta} { string tolower ! diff --git a/tools/uniParse.tcl b/tools/uniParse.tcl index 8576f9d..cce2138 100644 --- a/tools/uniParse.tcl +++ b/tools/uniParse.tcl @@ -44,17 +44,17 @@ proc uni::getValue {items index} { # Extract character info set category [lindex $items 2] - if {[scan [lindex $items 12] %4x toupper] == 1} { + if {[scan [lindex $items 12] %6x toupper] == 1} { set toupper [expr {$index - $toupper}] } else { set toupper {} } - if {[scan [lindex $items 13] %4x tolower] == 1} { + if {[scan [lindex $items 13] %6x tolower] == 1} { set tolower [expr {$tolower - $index}] } else { set tolower {} } - if {[scan [lindex $items 14] %4x totitle] == 1} { + if {[scan [lindex $items 14] %6x totitle] == 1} { set totitle [expr {$index - $totitle}] } else { set totitle {} @@ -101,25 +101,30 @@ proc uni::buildTables {data} { variable pMap {} variable pages {} variable groups {{0,,,}} + variable next 0 set info {} ;# temporary page info set mask [expr {(1 << $shift) - 1}] - set next 0 - foreach line [split $data \n] { if {$line eq ""} { - set line "FFFF;;Cn;0;ON;;;;;N;;;;;\n" + if {!($next & $mask)} { + # next character is already on page boundary + continue + } + # fill remaining page + set line [format %X [expr {($next-1)|$mask}]] + append line ";;Cn;0;ON;;;;;N;;;;;\n" } set items [split $line \;] scan [lindex $items 0] %x index - if {$index > 0xFFFF} then { - # Ignore non-BMP characters, as long as Tcl doesn't support them + if {$index >= 0xE0000} then { + # Ignore those characters, as they don't have case variants anyway continue } - set index [format 0x%0.4x $index] + set index [format %d $index] set gIndex [getGroup [getValue $items $index]] @@ -167,6 +172,7 @@ proc uni::main {} { variable groups variable shift variable titleCount + variable next if {$argc != 2} { puts stderr "\nusage: $argv0 \n" @@ -178,7 +184,7 @@ proc uni::main {} { buildTables $data puts "X = [llength $pMap] Y= [llength $pages] A= [llength $groups]" - set size [expr {[llength $pMap] + [llength $pages]*(1<<$shift)}] + set size [expr {[llength $pMap]*2 + [llength $pages]*(1<<$shift)}] puts "shift = $shift, space = $size" puts "title case count = $titleCount" @@ -316,15 +322,17 @@ static const int groups\[\] = {" } } puts $f $line - puts $f "}; + puts -nonewline $f "}; /* * The following constants are used to determine the category of a * Unicode character. */ -#define UNICODE_CATEGORY_MASK 0X1F - +#define UNICODE_CATEGORY_MASK 0x1F +#define UNICODE_OUT_OF_RANGE " + puts $f [format 0x%Xu $next] + puts $f " enum { UNASSIGNED, UPPERCASE_LETTER, @@ -365,15 +373,15 @@ enum { */ #define GetCaseType(info) (((info) & 0xE0) >> 5) -#define GetCategory(info) ((info) & 0x1F) +#define GetCategory(ch) (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) #define GetDelta(info) (((info) > 0) ? ((info) >> 15) : (~(~((info)) >> 15))) /* * This macro extracts the information about a character from the - * Unicode character tables. + * Unicode character tables. It may only be used for (unsigned) ch < UNICODE_OUT_OF_RANGE */ -#define GetUniCharInfo(ch) (groups\[groupMap\[(pageMap\[(((int)(ch)) & 0xffff) >> OFFSET_BITS\] << OFFSET_BITS) | ((ch) & ((1 << OFFSET_BITS)-1))\]\]) +#define GetUniCharInfo(ch) (groups\[groupMap\[(pageMap\[((int)(ch)) >> OFFSET_BITS\] << OFFSET_BITS) | ((ch) & ((1 << OFFSET_BITS)-1))\]\]) " close $f -- cgit v0.12 From 39ad9eb8f353ef5355a28d18349f6319bf9fcc9c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Aug 2011 08:32:39 +0000 Subject: fix tests utf-2.8 and utf-2.9 --- generic/tclUtf.c | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 5819bcd..14061df 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -564,8 +564,7 @@ Tcl_NumUtfChars( * for strlen(string). */ { Tcl_UniChar ch = 0; - register Tcl_UniChar *chPtr = &ch; - register int i; + register int i, n; /* * The separate implementations are faster. @@ -577,18 +576,23 @@ Tcl_NumUtfChars( i = 0; if (length < 0) { while (*src != '\0') { - src += TclUtfToUniChar(src, chPtr); + n = TclUtfToUniChar(src, &ch); + if (!n) { + n = Tcl_UtfToUniChar(src, &ch); + } + src += n; i++; } } else { - register int n; - while (length > 0) { if (UCHAR(*src) < 0xC0) { length--; src++; } else { - n = Tcl_UtfToUniChar(src, chPtr); + n = Tcl_UtfToUniChar(src, &ch); + if (!n) { + n = Tcl_UtfToUniChar(src, &ch); + } length -= n; src += n; } @@ -823,7 +827,7 @@ Tcl_UtfAtIndex( int len; while (index > 0) { - index--; + index--; len = TclUtfToUniChar(src, &ch); if (!len) { len = TclUtfToUniChar(src, &ch); -- cgit v0.12 From 4683dce51c55d4a3d5281e98f60e17b8c09d24fb Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 4 Mar 2012 16:52:01 +0000 Subject: Compilation of misc info sometimes used in high-performance code. --- generic/tclAssembly.c | 9 +- generic/tclCmdIL.c | 4 +- generic/tclCompCmds.c | 102 +++++++++++++++++-- generic/tclCompile.c | 21 +++- generic/tclCompile.h | 8 +- generic/tclExecute.c | 64 ++++++++++++ generic/tclInt.h | 9 ++ generic/tclNamesp.c | 275 +++++++++++++++++++++++++------------------------- tests/info.test | 6 ++ 9 files changed, 344 insertions(+), 154 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 5b32ab0..7bfaac1 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -369,6 +369,7 @@ TalInstDesc TalInstructionTable[] = { {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, + {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, @@ -406,6 +407,8 @@ TalInstDesc TalInstructionTable[] = { {"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1}, {"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM, 1, 1}, + {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, + {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 | INST_INVOKE_STK4), INT_MIN,1}, {"jump", ASSEM_JUMP, INST_JUMP1, 0, 0}, @@ -449,6 +452,7 @@ TalInstDesc TalInstructionTable[] = { {"neq", ASSEM_1BYTE, INST_NEQ, 2, 1}, {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, + {"nscurrent", ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, @@ -499,7 +503,10 @@ static unsigned char NonThrowingByteCodes[] = { INST_OVER, /* 95 */ INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ - INST_NOP /* 132 */ + INST_NOP, /* 132 */ + INST_NS_CURRENT, /* 141 */ + INST_COROUTINE_NAME, /* 142 */ + INST_INFO_LEVEL_NUM /* 143 */ }; /* diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b312026..3af577b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -166,7 +166,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0}, {"commands", InfoCommandsCmd, NULL, NULL, NULL, 0}, {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0}, - {"coroutine", TclInfoCoroutineCmd, NULL, NULL, NULL, 0}, + {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, {"default", InfoDefaultCmd, NULL, NULL, NULL, 0}, {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0}, {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, @@ -174,7 +174,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0}, {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0}, {"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0}, - {"level", InfoLevelCmd, NULL, NULL, NULL, 0}, + {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0}, {"library", InfoLibraryCmd, NULL, NULL, NULL, 0}, {"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0}, {"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5b7e0a5..79d29e9 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2817,22 +2817,47 @@ TclCompileIncrCmd( /* *---------------------------------------------------------------------- * - * TclCompileInfoExistsCmd -- + * TclCompileInfo*Cmd -- * - * Procedure called to compile the "info exists" subcommand. + * Procedures called to compile "info" subcommands. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "info exists" - * subcommand at runtime. + * Instructions are added to envPtr to execute the "info" subcommand at + * runtime. * *---------------------------------------------------------------------- */ int +TclCompileInfoCoroutineCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [info coroutine] without arguments. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_COROUTINE_NAME, envPtr); + return TCL_OK; +} + +int TclCompileInfoExistsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command @@ -2883,6 +2908,42 @@ TclCompileInfoExistsCmd( return TCL_OK; } + +int +TclCompileInfoLevelCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [info level] without arguments or with a single argument. + */ + + if (parsePtr->numWords == 1) { + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); + } else if (parsePtr->numWords != 2) { + return TCL_ERROR; + } else { + DefineLineInformation; /* TIP #280 */ + + /* + * Compile the argument, then add the instruction to convert it into a + * list of arguments. + */ + + SetLineInformation(1); + CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); + TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); + } + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -3700,11 +3761,11 @@ TclCompileLsetCmd( /* *---------------------------------------------------------------------- * - * TclCompileNamespaceCmd -- + * TclCompileNamespace*Cmd -- * - * Procedure called to compile the "namespace" command; currently, only - * the subcommand "namespace upvar" is compiled to bytecodes, and then - * only inside a procedure(-like) context. + * Procedures called to compile the "namespace" command; currently, only + * the subcommands "namespace current" and "namespace upvar" are compiled + * to bytecodes, and the latter only inside a procedure(-like) context. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer @@ -3718,6 +3779,31 @@ TclCompileLsetCmd( */ int +TclCompileNamespaceCurrentCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [namespace current] without arguments. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_NS_CURRENT, envPtr); + return TCL_OK; +} + +int TclCompileNamespaceUpvarCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1d88e11..6f3f778 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -37,7 +37,7 @@ TCL_DECLARE_MUTEX(tableMutex) int tclTraceCompile = 0; static int traceInitialized = 0; #endif - + /* * A table describing the Tcl bytecode instructions. Entries in this table * must correspond to the instruction opcode definitions in tclCompile.h. The @@ -435,6 +435,20 @@ InstructionDesc const tclInstructionTable[] = { * indicated by the LVT index. Part of [dict with]. * Stack: ... path keyList => ... */ + {"nscurrent", 1, +1, 0, {OPERAND_NONE}}, + /* Push the name of the interpreter's current namespace as an object + * on the stack. */ + {"coroName", 1, +1, 0, {OPERAND_NONE}}, + /* Push the name of the interpreter's current coroutine as an object + * on the stack. */ + {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}}, + /* Push the stack depth (i.e., [info level]) of the interpreter as an + * object on the stack. */ + {"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}}, + /* Push the argument words to a stack depth (i.e., [info level ]) + * of the interpreter as an object on the stack. + * Stack: ... depth => ... argList */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -1673,10 +1687,10 @@ TclCompileScript( && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { - int savedNumCmds = envPtr->numCommands; + int code, savedNumCmds = envPtr->numCommands; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; - int update = 0, code; + int update = 0; /* * Mark the start of the command; the proper bytecode @@ -4627,6 +4641,5 @@ RecordByteCodeStats( * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 - * indent-tabs-mode: nil * End: */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 58663fd..e12debf 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -681,8 +681,14 @@ typedef struct ByteCode { #define INST_DICT_RECOMBINE_STK 139 #define INST_DICT_RECOMBINE_IMM 140 +/* For compilation of basic information operations */ +#define INST_NS_CURRENT 141 +#define INST_COROUTINE_NAME 142 +#define INST_INFO_LEVEL_NUM 143 +#define INST_INFO_LEVEL_ARGS 144 + /* The last opcode */ -#define LAST_INST_OPCODE 140 +#define LAST_INST_OPCODE 144 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e402634..0c0de20 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4045,6 +4045,70 @@ TEBCresume( /* * ----------------------------------------------------------------- + * Start of general introspector instructions. + */ + + case INST_NS_CURRENT: { + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { + TclNewLiteralStringObj(objResultPtr, "::"); + } else { + TclNewStringObj(objResultPtr, currNsPtr->fullName, + strlen(currNsPtr->fullName)); + } + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + } + case INST_COROUTINE_NAME: { + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + TclNewObj(objResultPtr); + if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { + Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, + objResultPtr); + } + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + } + case INST_INFO_LEVEL_NUM: + TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + case INST_INFO_LEVEL_ARGS: { + int level; + register CallFrame *framePtr = iPtr->varFramePtr; + register CallFrame *rootFramePtr = iPtr->rootFramePtr; + + valuePtr = OBJ_AT_TOS; + if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) { + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + goto gotError; + } + TRACE(("%d => ", level)); + if (level <= 0) { + level += framePtr->level; + } + for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; + framePtr = framePtr->callerVarPtr) { + /* Empty loop body */ + } + if (framePtr == rootFramePtr) { + Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr), + "\"", NULL); + TRACE_APPEND(("ERROR: bad level\n")); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", + TclGetString(valuePtr), NULL); + goto gotError; + } + objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } + + /* + * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 08b3f70..bc7cd9f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3526,9 +3526,15 @@ MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoCoroutineCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3556,6 +3562,9 @@ MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 73bc644..cdaba3d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -104,7 +104,7 @@ static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NRNamespaceEvalCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, @@ -160,25 +160,25 @@ static const Tcl_ObjType nsNameType = { */ static const EnsembleImplMap defaultNamespaceMap[] = { - {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0}, - {"code", NamespaceCodeCmd, NULL, NULL, NULL, 0}, - {"current", NamespaceCurrentCmd, NULL, NULL, NULL, 0}, - {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0}, - {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, - {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, - {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0}, - {"export", NamespaceExportCmd, NULL, NULL, NULL, 0}, - {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0}, - {"import", NamespaceImportCmd, NULL, NULL, NULL, 0}, - {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, - {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0}, - {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0}, - {"path", NamespacePathCmd, NULL, NULL, NULL, 0}, - {"qualifiers", NamespaceQualifiersCmd, NULL, NULL, NULL, 0}, - {"tail", NamespaceTailCmd, NULL, NULL, NULL, 0}, - {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0}, - {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, - {"which", NamespaceWhichCmd, NULL, NULL, NULL, 0}, + {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0}, + {"code", NamespaceCodeCmd, NULL, NULL, NULL, 0}, + {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, + {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0}, + {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, + {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, + {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0}, + {"export", NamespaceExportCmd, NULL, NULL, NULL, 0}, + {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0}, + {"import", NamespaceImportCmd, NULL, NULL, NULL, 0}, + {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, + {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0}, + {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0}, + {"path", NamespacePathCmd, NULL, NULL, NULL, 0}, + {"qualifiers", NamespaceQualifiersCmd, NULL, NULL, NULL, 0}, + {"tail", NamespaceTailCmd, NULL, NULL, NULL, 0}, + {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0}, + {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, + {"which", NamespaceWhichCmd, NULL, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -423,7 +423,7 @@ Tcl_PopCallFrame( framePtr->nsPtr = NULL; if (framePtr->tailcallPtr) { - TclSpliceTailcall(interp, framePtr->tailcallPtr); + TclSpliceTailcall(interp, framePtr->tailcallPtr); } } @@ -690,8 +690,8 @@ Tcl_CreateNamespace( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't create namespace \"\": " "only global namespace can have empty name", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEGLOBAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEGLOBAL", NULL); return NULL; } else { /* @@ -727,8 +727,8 @@ Tcl_CreateNamespace( ) { Tcl_AppendResult(interp, "can't create namespace \"", name, "\": already exists", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEEXISTING", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); return NULL; } } @@ -1339,7 +1339,7 @@ Tcl_Export( if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendResult(interp, "invalid export pattern \"", pattern, "\": pattern can't specify a namespace", NULL); - Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); return TCL_ERROR; } @@ -1544,7 +1544,7 @@ Tcl_Import( if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, @@ -1562,12 +1562,12 @@ Tcl_Import( Tcl_AppendResult(interp, "no namespace specified in import pattern \"", pattern, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); } else { Tcl_AppendResult(interp, "import pattern \"", pattern, "\" tries to import from namespace \"", importNsPtr->name, "\" into itself", NULL); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); } return TCL_ERROR; } @@ -1689,7 +1689,7 @@ DoImport( "\" would create a loop containing command \"", Tcl_DStringValue(&ds), "\"", NULL); Tcl_DStringFree(&ds); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } @@ -1729,7 +1729,7 @@ DoImport( } Tcl_AppendResult(interp, "can't import command \"", cmdName, "\": already exists", NULL); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } return TCL_OK; @@ -3286,12 +3286,12 @@ NRNamespaceEvalCmd( } if (iPtr->ensembleRewrite.sourceObjs == NULL) { - framePtr->objc = objc; - framePtr->objv = objv; + framePtr->objc = objc; + framePtr->objv = objv; } else { - framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs - - iPtr->ensembleRewrite.numInsertedObjs; - framePtr->objv = iPtr->ensembleRewrite.sourceObjs; + framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + framePtr->objv = iPtr->ensembleRewrite.sourceObjs; } if (objc == 3) { @@ -3749,12 +3749,12 @@ NRNamespaceInscopeCmd( } if (iPtr->ensembleRewrite.sourceObjs == NULL) { - framePtr->objc = objc; - framePtr->objv = objv; + framePtr->objc = objc; + framePtr->objv = objv; } else { - framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs - - iPtr->ensembleRewrite.numInsertedObjs; - framePtr->objv = iPtr->ensembleRewrite.sourceObjs; + framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + framePtr->objv = iPtr->ensembleRewrite.sourceObjs; } /* @@ -3959,15 +3959,15 @@ NamespacePathCmd( */ if (objc == 1) { - Tcl_Obj *resultObj = Tcl_NewObj(); + Tcl_Obj *resultObj = Tcl_NewObj(); for (i=0 ; icommandPathLength ; i++) { if (nsPtr->commandPathArray[i].nsPtr != NULL) { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( - nsPtr->commandPathArray[i].nsPtr->fullName, -1)); + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( + nsPtr->commandPathArray[i].nsPtr->fullName, -1)); } } - Tcl_SetObjResult(interp, resultObj); + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -4844,8 +4844,8 @@ TclLogCommandInfo( int length, /* Number of bytes in command (-1 means use * all bytes up to first null byte). */ const unsigned char *pc, /* Current pc of bytecode execution context */ - Tcl_Obj **tosPtr) /* Current stack of bytecode execution - * context */ + Tcl_Obj **tosPtr) /* Current stack of bytecode execution + * context */ { register const char *p; Interp *iPtr = (Interp *) interp; @@ -4862,55 +4862,55 @@ TclLogCommandInfo( } if (command != NULL) { - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - if (length < 0) { - length = strlen(command); - } - overflow = (length > limit); - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + if (length < 0) { + length = strlen(command); + } + overflow = (length > limit); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) ? "while executing" : "invoked from within"), (overflow ? limit : length), command, (overflow ? "..." : ""))); - varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, + varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, NULL, 0, 0, &arrayPtr); - if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { - /* - * Should not happen. - */ - - return; - } else { - Tcl_HashEntry *hPtr + if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { + /* + * Should not happen. + */ + + return; + } else { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); - VarTrace *tracePtr = Tcl_GetHashValue(hPtr); + VarTrace *tracePtr = Tcl_GetHashValue(hPtr); - if (tracePtr->traceProc != EstablishErrorInfoTraces) { - /* - * The most recent trace set on ::errorInfo is not the one the - * core itself puts on last. This means some other code is + if (tracePtr->traceProc != EstablishErrorInfoTraces) { + /* + * The most recent trace set on ::errorInfo is not the one the + * core itself puts on last. This means some other code is * tracing the variable, and the additional trace(s) might be * write traces that expect the timing of writes to * ::errorInfo that existed Tcl releases before 8.5. To * satisfy that compatibility need, we write the current * -errorinfo value to the ::errorInfo variable. - */ + */ - Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); - } - } + } + } } /* @@ -4918,60 +4918,60 @@ TclLogCommandInfo( */ if (Tcl_IsShared(iPtr->errorStack)) { - Tcl_Obj *newObj; - - newObj = Tcl_DuplicateObj(iPtr->errorStack); - Tcl_DecrRefCount(iPtr->errorStack); - Tcl_IncrRefCount(newObj); - iPtr->errorStack = newObj; + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; } if (iPtr->resetErrorStack) { int len; - iPtr->resetErrorStack = 0; + iPtr->resetErrorStack = 0; Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* - * Reset while keeping the list intrep as much as possible. - */ - - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); - if (pc != NULL) { - Tcl_Obj *innerContext; - - innerContext = TclGetInnerContext(interp, pc, tosPtr); - if (innerContext != NULL) { - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - iPtr->innerLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext); - } - } else if (command != NULL) { - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - iPtr->innerLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - Tcl_NewStringObj(command, length)); - } + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + if (pc != NULL) { + Tcl_Obj *innerContext; + + innerContext = TclGetInnerContext(interp, pc, tosPtr); + if (innerContext != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext); + } + } else if (command != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(command, length)); + } } if (!iPtr->framePtr->objc) { - /* - * Special frame, nothing to report. - */ + /* + * Special frame, nothing to report. + */ } else if (iPtr->varFramePtr != iPtr->framePtr) { - /* - * uplevel case, [lappend errorstack UP $relativelevel] - */ + /* + * uplevel case, [lappend errorstack UP $relativelevel] + */ - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( iPtr->framePtr->level - iPtr->varFramePtr->level)); } else if (iPtr->framePtr != iPtr->rootFramePtr) { - /* - * normal case, [lappend errorstack CALL [info level 0]] - */ + /* + * normal case, [lappend errorstack CALL [info level 0]] + */ - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( iPtr->framePtr->objc, iPtr->framePtr->objv)); } } @@ -4981,8 +4981,8 @@ TclLogCommandInfo( * * TclErrorStackResetIf -- * - * The TIP 348 reset/no-bc part of TLCI, for specific use by - * TclCompileSyntaxError. + * The TIP 348 reset/no-bc part of TLCI, for specific use by + * TclCompileSyntaxError. * * Results: * None. @@ -5003,27 +5003,27 @@ TclErrorStackResetIf( Interp *iPtr = (Interp *) interp; if (Tcl_IsShared(iPtr->errorStack)) { - Tcl_Obj *newObj; - - newObj = Tcl_DuplicateObj(iPtr->errorStack); - Tcl_DecrRefCount(iPtr->errorStack); - Tcl_IncrRefCount(newObj); - iPtr->errorStack = newObj; + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; } if (iPtr->resetErrorStack) { int len; - iPtr->resetErrorStack = 0; + iPtr->resetErrorStack = 0; Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* - * Reset while keeping the list intrep as much as possible. - */ + /* + * Reset while keeping the list intrep as much as possible. + */ - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - Tcl_NewStringObj(msg, length)); + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(msg, length)); } } @@ -5066,6 +5066,5 @@ Tcl_LogCommandInfo( * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 - * indent-tabs-mode: nil * End: */ diff --git a/tests/info.test b/tests/info.test index 3323281..a9f740e 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1955,6 +1955,12 @@ test info-38.2 {location information for uplevel, dl, direct-literal} -match glo * {type source line 1951 file info.test cmd etrace level 1} * {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub} +# This test at the end of this file _only_ to avoid disturbing above line +# numbers. It _belongs_ after info-9.12 +test info-9.13 {info level option, value in global context} -body { + uplevel #0 {info level 2} +} -returnCodes error -result {bad level "2"} + # ------------------------------------------------------------------------- unset -nocomplain res -- cgit v0.12 From d9cfa9ca3b6b1b18e767a1a8038bb89ccccdf3a2 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 31 Mar 2012 13:48:11 +0000 Subject: Start of implementation of TIP 400: zlib improvements --- generic/tcl.decls | 4 ++++ generic/tclDecls.h | 5 +++++ generic/tclStubInit.c | 1 + generic/tclZlib.c | 23 ++++++++++++++++++++++- 4 files changed, 32 insertions(+), 1 deletion(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 7e5bbbb..bb9f71e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2318,6 +2318,10 @@ declare 629 { int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr) } +declare 630 { + void* Tcl_ZlibStreamGetZstreamp(Tcl_ZlibStream zshandle) +} + # ----- BASELINE -- FOR -- 8.6.0 ----- # ############################################################################## diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1f7dfe6..1d6a866 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1807,6 +1807,8 @@ EXTERN void* Tcl_FindSymbol(Tcl_Interp *interp, /* 629 */ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr); +/* 630 */ +EXTERN void* Tcl_ZlibStreamGetZstreamp(Tcl_ZlibStream zshandle); typedef struct TclStubHooks { const struct TclPlatStubs *tclPlatStubs; @@ -2472,6 +2474,7 @@ typedef struct TclStubs { int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void* (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ + void* (*tcl_ZlibStreamGetZstreamp) (Tcl_ZlibStream zshandle); /* 630 */ } TclStubs; #ifdef __cplusplus @@ -3764,6 +3767,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ +#define Tcl_ZlibStreamGetZstreamp \ + (tclStubsPtr->tcl_ZlibStreamGetZstreamp) /* 630 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 32e9557..eec540c 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1301,6 +1301,7 @@ const TclStubs tclStubs = { Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ + Tcl_ZlibStreamGetZstreamp, /* 630 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 81012dc..6f82e06 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -864,7 +864,7 @@ Tcl_ZlibStreamEof( */ int -Tcl_ZlibStreamChecksum( +Tcl_ZlibStreamGetZstreamp( Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */ { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; @@ -875,6 +875,27 @@ Tcl_ZlibStreamChecksum( /* *---------------------------------------------------------------------- * + * Tcl_ZlibStreamGetZstreamp -- + * + * Return the z_streamp for the stream (though not typed as such, so as + * to avoid type interface poisoning). Shouldn't be used to poke around + * excessively. + * + *---------------------------------------------------------------------- + */ + +void * +Tcl_ZlibStreamGetZstreamp( + Tcl_ZlibStream zshandle) +{ + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; + + return &zshPtr->stream; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ZlibStreamPut -- * * Add data to the stream for compression or decompression from a -- cgit v0.12 From 354910b5c589f340145d0d2c49be5fe460e0613e Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 31 Mar 2012 14:06:43 +0000 Subject: D'oh! --- generic/tclZlib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 6f82e06..2e5a833 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -864,7 +864,7 @@ Tcl_ZlibStreamEof( */ int -Tcl_ZlibStreamGetZstreamp( +Tcl_ZlibStreamChecksum( Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */ { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; -- cgit v0.12 From a4c60c3914ce47914ad4085819ef4043beeea278 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 31 Mar 2012 15:16:45 +0000 Subject: Another step on the road to implementation. --- generic/tclZlib.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 67 insertions(+), 2 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 2e5a833..85c6655 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -64,6 +64,9 @@ typedef struct { int wbits; /* The encoded compression mode, so we can * restart the stream if necessary. */ Tcl_Command cmd; /* Token for the associated Tcl command. */ + Tcl_Obj *compDictObj; /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ } ZlibStreamHandle; /* @@ -209,6 +212,7 @@ ConvertError( case Z_MEM_ERROR: codeStr = "MEM"; break; case Z_BUF_ERROR: codeStr = "BUF"; break; case Z_VERSION_ERROR: codeStr = "VERSION"; break; + case Z_NEED_DICT: codeStr = "NEED_DICT"; break; default: codeStr = "unknown"; codeStr2 = codeStrBuf; @@ -542,6 +546,7 @@ Tcl_ZlibStreamInit( zshPtr->wbits = wbits; zshPtr->currentInput = NULL; zshPtr->streamEnd = 0; + zshPtr->compDictObj = NULL; memset(&zshPtr->stream, 0, sizeof(z_stream)); /* @@ -551,6 +556,14 @@ Tcl_ZlibStreamInit( if (mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e == Z_OK && zshPtr->compDictObj) { + int dictLen; + unsigned char *dictBytes = + Tcl_GetByteArrayFromObj(zshPtr->compDictObj, &dictLen); + + e = deflateSetDictionary(&zshPtr->stream, dictBytes, + (unsigned) dictLen); + } } else { e = inflateInit2(&zshPtr->stream, wbits); } @@ -618,6 +631,9 @@ Tcl_ZlibStreamInit( return TCL_OK; error: + if (zshPtr->compDictObj) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } ckfree(zshPtr); return TCL_ERROR; } @@ -725,6 +741,9 @@ ZlibStreamCleanup( if (zshPtr->currentInput) { Tcl_DecrRefCount(zshPtr->currentInput); } + if (zshPtr->compDictObj) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } ckfree(zshPtr); } @@ -777,6 +796,14 @@ Tcl_ZlibStreamReset( if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED, zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e == Z_OK && zshPtr->compDictObj) { + int dictLen; + unsigned char *dictBytes = + Tcl_GetByteArrayFromObj(zshPtr->compDictObj, &dictLen); + + e = deflateSetDictionary(&zshPtr->stream, dictBytes, + (unsigned) dictLen); + } } else { e = inflateInit2(&zshPtr->stream, zshPtr->wbits); } @@ -1091,7 +1118,22 @@ Tcl_ZlibStreamGet( } } - e = inflate(&zshPtr->stream, zshPtr->flush); + while (1) { + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e != Z_NEED_DICT || zshPtr->compDictObj == NULL) { + break; + } else { + int dictLen; + unsigned char *dictBytes = + Tcl_GetByteArrayFromObj(zshPtr->compDictObj,&dictLen); + + e = inflateSetDictionary(&zshPtr->stream, dictBytes, + (unsigned) dictLen); + if (e != Z_OK) { + break; + } + } + } Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) @@ -1145,7 +1187,23 @@ Tcl_ZlibStreamGet( * And call inflate again. */ - e = inflate(&zshPtr->stream, zshPtr->flush); + while (1) { + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e != Z_NEED_DICT || zshPtr->compDictObj == NULL) { + break; + } else { + int dictLen; + unsigned char *dictBytes = + Tcl_GetByteArrayFromObj(zshPtr->compDictObj, + &dictLen); + + e = inflateSetDictionary(&zshPtr->stream, dictBytes, + (unsigned) dictLen); + if (e != Z_OK) { + break; + } + } + } } if (zshPtr->stream.avail_out > 0) { Tcl_SetByteArrayLength(data, @@ -2994,6 +3052,13 @@ Tcl_ZlibAdler32( { return 0; } + +void * +Tcl_ZlibStreamGetZstreamp( + Tcl_ZlibStream zshandle) +{ + return NULL; +} #endif /* HAVE_ZLIB */ /* -- cgit v0.12 From aa4019193878d7ae83b0fefd3f76ae3abc671129 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 7 Apr 2012 17:41:10 +0000 Subject: Another bit more --- generic/tclZlib.c | 87 ++++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 73 insertions(+), 14 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 85c6655..6ac1a59 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1879,52 +1879,111 @@ ZlibCmd( return TCL_ERROR; } return TCL_OK; - case CMD_STREAM: /* stream deflate/inflate/...gunzip \ + case CMD_STREAM: { /* stream deflate/inflate/...gunzip \ * ?level? * -> handleCmd */ - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); + Tcl_Obj *compDictObj = NULL; + Tcl_Obj *gzipHeaderObj = NULL; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?options...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, &format) != TCL_OK) { return TCL_ERROR; } - mode = TCL_ZLIB_STREAM_INFLATE; switch ((enum zlibFormats) format) { case FMT_DEFLATE: + if (objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); + return TCL_ERROR; + } mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_RAW; + level = Z_DEFAULT_COMPRESSION; + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level < 0 || level > 9) { + goto badLevel; + } + } + break; case FMT_INFLATE: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "mode"); + return TCL_ERROR; + } + mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_RAW; + level = Z_DEFAULT_COMPRESSION; break; case FMT_COMPRESS: + if (objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); + return TCL_ERROR; + } mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + level = Z_DEFAULT_COMPRESSION; + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level < 0 || level > 9) { + goto badLevel; + } + } + break; case FMT_DECOMPRESS: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "mode"); + return TCL_ERROR; + } + mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_ZLIB; + level = Z_DEFAULT_COMPRESSION; break; case FMT_GZIP: + if (objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); + return TCL_ERROR; + } mode = TCL_ZLIB_STREAM_DEFLATE; - case FMT_GUNZIP: format = TCL_ZLIB_FORMAT_GZIP; + level = Z_DEFAULT_COMPRESSION; + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level < 0 || level > 9) { + goto badLevel; + } + } break; - } - if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], - (int *) &level) != TCL_OK) { + case FMT_GUNZIP: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "mode"); return TCL_ERROR; } - if (level < 0 || level > 9) { - goto badLevel; - } - } else { + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_GZIP; level = Z_DEFAULT_COMPRESSION; + break; } - if (Tcl_ZlibStreamInit(interp, mode, format, level, NULL, + if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj, &zh) != TCL_OK) { return TCL_ERROR; } + if (compDictObj != NULL) { + ((ZlibStreamHandle *) zh)->compDictObj = compDictObj; + Tcl_IncrRefCount(compDictObj); + } Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); return TCL_OK; + } case CMD_PUSH: { /* push mode channel options... * -> channel */ Tcl_Channel chan; -- cgit v0.12 From 95eb3ddcaae1b40043dd6413673ee7c2a2a4e797 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 8 Apr 2012 17:16:43 +0000 Subject: Another few bits of zlib stream core hacking --- generic/tclZlib.c | 50 ++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 44 insertions(+), 6 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 6ac1a59..35513d5 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -67,6 +67,8 @@ typedef struct { Tcl_Obj *compDictObj; /* Byte-array object containing compression * dictionary (not dictObj!) to use if * necessary. */ + GzipHeader *gzHeaderPtr; /* If we've allocated a gzip header + * structure. */ } ZlibStreamHandle; /* @@ -298,7 +300,9 @@ GenerateHeader( NULL); headerPtr->nativeCommentBuf[len] = '\0'; headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf; - *extraSizePtr += len; + if (extraSizePtr != NULL) { + *extraSizePtr += len; + } } if (GetValue(interp, dictObj, "crc", &value) != TCL_OK) { @@ -316,7 +320,9 @@ GenerateHeader( headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); headerPtr->nativeFilenameBuf[len] = '\0'; headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf; - *extraSizePtr += len; + if (extraSizePtr != NULL) { + *extraSizePtr += len; + } } if (GetValue(interp, dictObj, "os", &value) != TCL_OK) { @@ -480,6 +486,7 @@ Tcl_ZlibStreamInit( ZlibStreamHandle *zshPtr = NULL; Tcl_DString cmdname; Tcl_CmdInfo cmdinfo; + GzipHeader *gzHeaderPtr = NULL; switch (mode) { case TCL_ZLIB_STREAM_DEFLATE: @@ -494,6 +501,15 @@ Tcl_ZlibStreamInit( break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; + if (dictObj) { + gzHeaderPtr = ckalloc(sizeof(GzipHeader)); + memset(gzHeaderPtr, 0, sizeof(GzipHeader)); + if (GenerateHeader(interp, dictObj, gzHeaderPtr, + NULL) != TCL_OK) { + ckfree(gzHeaderPtr); + return TCL_ERROR; + } + } break; case TCL_ZLIB_FORMAT_ZLIB: wbits = WBITS_ZLIB; @@ -520,6 +536,14 @@ Tcl_ZlibStreamInit( break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; + gzHeaderPtr = ckalloc(sizeof(GzipHeader)); + memset(gzHeaderPtr, 0, sizeof(GzipHeader)); + gzHeaderPtr->header.name = (Bytef *) + gzHeaderPtr->nativeFilenameBuf; + gzHeaderPtr->header.name_max = MAXPATHLEN - 1; + gzHeaderPtr->header.comment = (Bytef *) + gzHeaderPtr->nativeCommentBuf; + gzHeaderPtr->header.name_max = MAX_COMMENT_LEN - 1; break; case TCL_ZLIB_FORMAT_ZLIB: wbits = WBITS_ZLIB; @@ -547,6 +571,7 @@ Tcl_ZlibStreamInit( zshPtr->currentInput = NULL; zshPtr->streamEnd = 0; zshPtr->compDictObj = NULL; + zshPtr->gzHeaderPtr = gzHeaderPtr; memset(&zshPtr->stream, 0, sizeof(z_stream)); /* @@ -556,6 +581,10 @@ Tcl_ZlibStreamInit( if (mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e == Z_OK && zshPtr->gzHeaderPtr) { + e = deflateSetHeader(&zshPtr->stream, + &zshPtr->gzHeaderPtr->header); + } if (e == Z_OK && zshPtr->compDictObj) { int dictLen; unsigned char *dictBytes = @@ -566,6 +595,10 @@ Tcl_ZlibStreamInit( } } else { e = inflateInit2(&zshPtr->stream, wbits); + if (e == Z_OK && zshPtr->gzHeaderPtr) { + e = inflateGetHeader(&zshPtr->stream, + &zshPtr->gzHeaderPtr->header); + } } if (e != Z_OK) { @@ -630,10 +663,14 @@ Tcl_ZlibStreamInit( } return TCL_OK; - error: + + error: if (zshPtr->compDictObj) { Tcl_DecrRefCount(zshPtr->compDictObj); } + if (zshPtr->gzHeaderPtr) { + ckfree(zshPtr->gzHeaderPtr); + } ckfree(zshPtr); return TCL_ERROR; } @@ -744,6 +781,9 @@ ZlibStreamCleanup( if (zshPtr->compDictObj) { Tcl_DecrRefCount(zshPtr->compDictObj); } + if (zshPtr->gzHeaderPtr) { + ckfree(zshPtr->gzHeaderPtr); + } ckfree(zshPtr); } @@ -2880,11 +2920,9 @@ ZlibStackChannelTransform( if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) { if (mode == TCL_ZLIB_STREAM_DEFLATE) { if (gzipHeaderDictPtr) { - int dummy = 0; - cd->flags |= OUT_HEADER; if (GenerateHeader(interp, gzipHeaderDictPtr, &cd->outHeader, - &dummy) != TCL_OK) { + NULL) != TCL_OK) { goto error; } } -- cgit v0.12 From 129b4229f0156af9424e7f2d9cc8500f21ac4bcd Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 10 Apr 2012 07:29:38 +0000 Subject: Argument parsing update --- generic/tclZlib.c | 116 +++++++++++++++++++++++++++--------------------------- 1 file changed, 58 insertions(+), 58 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 35513d5..ecc4f07 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1920,13 +1920,34 @@ ZlibCmd( } return TCL_OK; case CMD_STREAM: { /* stream deflate/inflate/...gunzip \ - * ?level? + * ?options...? * -> handleCmd */ + typedef struct { + const char *name; + Tcl_Obj **valueVar; + } OptDescriptor; Tcl_Obj *compDictObj = NULL; Tcl_Obj *gzipHeaderObj = NULL; + Tcl_Obj *levelObj = NULL; + OptDescriptor compressionOpts[] = { + { "-dictionary", &compDictObj }, + { "-level", &levelObj }, + { NULL, NULL } + }; + OptDescriptor gzipOpts[] = { + { "-dictionary", &compDictObj }, + { "-header", &gzipHeaderObj }, + { "-level", &levelObj }, + { NULL, NULL } + }; + OptDescriptor expansionOpts[] = { + { "-dictionary", &compDictObj }, + { NULL, NULL } + }; + OptDescriptor *desc; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?options...?"); + if (objc < 3 || !(objc & 1)) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?-option value...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, @@ -1935,90 +1956,69 @@ ZlibCmd( } switch ((enum zlibFormats) format) { case FMT_DEFLATE: - if (objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); - return TCL_ERROR; - } + desc = compressionOpts; mode = TCL_ZLIB_STREAM_DEFLATE; format = TCL_ZLIB_FORMAT_RAW; - level = Z_DEFAULT_COMPRESSION; - if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { - return TCL_ERROR; - } - if (level < 0 || level > 9) { - goto badLevel; - } - } break; case FMT_INFLATE: - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "mode"); - return TCL_ERROR; - } + desc = expansionOpts; mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_RAW; - level = Z_DEFAULT_COMPRESSION; break; case FMT_COMPRESS: - if (objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); - return TCL_ERROR; - } + desc = compressionOpts; mode = TCL_ZLIB_STREAM_DEFLATE; format = TCL_ZLIB_FORMAT_ZLIB; - level = Z_DEFAULT_COMPRESSION; - if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { - return TCL_ERROR; - } - if (level < 0 || level > 9) { - goto badLevel; - } - } break; case FMT_DECOMPRESS: - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "mode"); - return TCL_ERROR; - } + desc = expansionOpts; mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_ZLIB; - level = Z_DEFAULT_COMPRESSION; break; case FMT_GZIP: - if (objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); - return TCL_ERROR; - } + desc = gzipOpts; mode = TCL_ZLIB_STREAM_DEFLATE; format = TCL_ZLIB_FORMAT_GZIP; - level = Z_DEFAULT_COMPRESSION; - if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { - return TCL_ERROR; - } - if (level < 0 || level > 9) { - goto badLevel; - } - } break; case FMT_GUNZIP: - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "mode"); - return TCL_ERROR; - } + desc = expansionOpts; mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_GZIP; - level = Z_DEFAULT_COMPRESSION; break; } + + for (i=3 ; i 9) { + goto badLevel; + } + } + if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj, &zh) != TCL_OK) { return TCL_ERROR; } if (compDictObj != NULL) { - ((ZlibStreamHandle *) zh)->compDictObj = compDictObj; + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zh; + + zshPtr->compDictObj = compDictObj; Tcl_IncrRefCount(compDictObj); } Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); -- cgit v0.12 From ad27974fb009113140a3de43ef54ae9f3ad8504a Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 11 Apr 2012 07:16:45 +0000 Subject: towards dictionary setting on transforms --- generic/tclZlib.c | 146 ++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 93 insertions(+), 53 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index ecc4f07..068308a 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -95,6 +95,9 @@ typedef struct { GzipHeader outHeader; /* Header to write to an output stream, when * compressing a gzip stream. */ Tcl_TimerToken timer; /* Timer used for keeping events fresh. */ + Tcl_Obj *compDictObj; /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ } ZlibChannelData; /* @@ -146,7 +149,8 @@ static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, int mode, int format, int level, - Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr); + Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr, + Tcl_Obj *compDictObj); static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); static void ZlibTransformTimerKill(ZlibChannelData *cd); static void ZlibTransformTimerRun(ClientData clientData); @@ -448,6 +452,34 @@ ExtractHeader( } } +static int +SetInflateDictionary( + z_streamp strm, + Tcl_Obj *compDictObj) +{ + if (compDictObj != NULL) { + int length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + + return inflateSetDictionary(strm, bytes, (unsigned) length); + } + return Z_OK; +} + +static int +SetDeflateDictionary( + z_streamp strm, + Tcl_Obj *compDictObj) +{ + if (compDictObj != NULL) { + int length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + + return deflateSetDictionary(strm, bytes, (unsigned) length); + } + return Z_OK; +} + /* *---------------------------------------------------------------------- * @@ -586,12 +618,7 @@ Tcl_ZlibStreamInit( &zshPtr->gzHeaderPtr->header); } if (e == Z_OK && zshPtr->compDictObj) { - int dictLen; - unsigned char *dictBytes = - Tcl_GetByteArrayFromObj(zshPtr->compDictObj, &dictLen); - - e = deflateSetDictionary(&zshPtr->stream, dictBytes, - (unsigned) dictLen); + e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); } } else { e = inflateInit2(&zshPtr->stream, wbits); @@ -599,6 +626,9 @@ Tcl_ZlibStreamInit( e = inflateGetHeader(&zshPtr->stream, &zshPtr->gzHeaderPtr->header); } + if (format==TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj && e==Z_OK) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + } } if (e != Z_OK) { @@ -837,15 +867,14 @@ Tcl_ZlibStreamReset( e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED, zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); if (e == Z_OK && zshPtr->compDictObj) { - int dictLen; - unsigned char *dictBytes = - Tcl_GetByteArrayFromObj(zshPtr->compDictObj, &dictLen); - - e = deflateSetDictionary(&zshPtr->stream, dictBytes, - (unsigned) dictLen); + e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); } } else { e = inflateInit2(&zshPtr->stream, zshPtr->wbits); + if (zshPtr->format == TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj + && e == Z_OK) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + } } if (e != Z_OK) { @@ -1158,22 +1187,13 @@ Tcl_ZlibStreamGet( } } - while (1) { - e = inflate(&zshPtr->stream, zshPtr->flush); - if (e != Z_NEED_DICT || zshPtr->compDictObj == NULL) { - break; - } else { - int dictLen; - unsigned char *dictBytes = - Tcl_GetByteArrayFromObj(zshPtr->compDictObj,&dictLen); - - e = inflateSetDictionary(&zshPtr->stream, dictBytes, - (unsigned) dictLen); - if (e != Z_OK) { - break; - } + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e == Z_NEED_DICT && zshPtr->compDictObj) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + e = inflate(&zshPtr->stream, zshPtr->flush); } - } + }; Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) @@ -1227,21 +1247,11 @@ Tcl_ZlibStreamGet( * And call inflate again. */ - while (1) { - e = inflate(&zshPtr->stream, zshPtr->flush); - if (e != Z_NEED_DICT || zshPtr->compDictObj == NULL) { - break; - } else { - int dictLen; - unsigned char *dictBytes = - Tcl_GetByteArrayFromObj(zshPtr->compDictObj, - &dictLen); - - e = inflateSetDictionary(&zshPtr->stream, dictBytes, - (unsigned) dictLen); - if (e != Z_OK) { - break; - } + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e == Z_NEED_DICT && zshPtr->compDictObj) { + e = SetInflateDictionary(&zshPtr->stream,zshPtr->compDictObj); + if (e == Z_OK) { + e = inflate(&zshPtr->stream, zshPtr->flush); } } } @@ -2160,7 +2170,7 @@ ZlibCmd( } if (ZlibStackChannelTransform(interp, mode, format, level, chan, - headerObj) == NULL) { + headerObj, NULL) == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, objv[3]); @@ -2481,12 +2491,10 @@ ZlibTransformClose( /* TODO: is this the right way to do errors on close? * Note: when close is called from FinalizeIOSubsystem * then interp may be NULL */ - if (!TclInThreadExit()) { - if (interp) { - Tcl_AppendResult(interp, - "error while finalizing file: ", - Tcl_PosixError(interp), NULL); - } + if (!TclInThreadExit() && interp) { + Tcl_AppendResult(interp, + "error while finalizing file: ", + Tcl_PosixError(interp), NULL); } result = TCL_ERROR; break; @@ -2538,6 +2546,12 @@ ZlibTransformInput( } while (1) { e = inflate(&cd->inStream, flush); + if (e == Z_NEED_DICT && cd->compDictObj) { + e = SetInflateDictionary(&cd->inStream, cd->compDictObj); + if (e == Z_OK) { + continue; + } + } if ((e == Z_STREAM_END) || (e==Z_OK && cd->inStream.avail_out==0)) { return toRead - cd->inStream.avail_out; } @@ -2651,9 +2665,13 @@ ZlibTransformSetOption( /* not used */ ZlibChannelData *cd = instanceData; Tcl_DriverSetOptionProc *setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "flush"; + static const char *chanOptions = "dictionary flush"; int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE); + if (optionName && strcmp(optionName, "-dictionary") == 0) { + // TODO dictionary option + } + if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) { int flushType; @@ -2715,7 +2733,7 @@ ZlibTransformGetOption( ZlibChannelData *cd = instanceData; Tcl_DriverGetOptionProc *getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "checksum header"; + static const char *chanOptions = "checksum dictionary header"; /* * The "crc" option reports the current CRC (calculated with the Adler32 @@ -2743,6 +2761,10 @@ ZlibTransformGetOption( } } + if (optionName == NULL || strcmp(optionName, "-dictionary") == 0) { + // TODO dictionary option + } + /* * The "header" option, which is only valid on inflating gzip channels, * reports the header that has been read from the start of the stream. @@ -2901,9 +2923,12 @@ ZlibStackChannelTransform( int level, /* What compression level to use. Ignored for * decompressing transforms. */ Tcl_Channel channel, /* The channel to attach to. */ - Tcl_Obj *gzipHeaderDictPtr) /* A description of header to use, or NULL to + Tcl_Obj *gzipHeaderDictPtr, /* A description of header to use, or NULL to * use a default. Ignored if not compressing * to produce gzip-format data. */ + Tcl_Obj *compDictObj) /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ { ZlibChannelData *cd = ckalloc(sizeof(ZlibChannelData)); Tcl_Channel chan; @@ -2937,6 +2962,12 @@ ZlibStackChannelTransform( } } + if (compDictObj != NULL) { + cd->compDictObj = Tcl_DuplicateObj(compDictObj); + Tcl_IncrRefCount(cd->compDictObj); + Tcl_GetByteArrayFromObj(cd->compDictObj, NULL); + } + if (format == TCL_ZLIB_FORMAT_RAW) { wbits = WBITS_RAW; } else if (format == TCL_ZLIB_FORMAT_ZLIB) { @@ -2980,6 +3011,12 @@ ZlibStackChannelTransform( goto error; } } + if (cd->compDictObj) { + e = SetDeflateDictionary(&cd->outStream, cd->compDictObj); + if (e != Z_OK) { + goto error; + } + } } chan = Tcl_StackChannel(interp, &zlibChannelType, cd, @@ -3001,6 +3038,9 @@ ZlibStackChannelTransform( ckfree(cd->outBuffer); deflateEnd(&cd->outStream); } + if (cd->compDictObj) { + Tcl_DecrRefCount(cd->compDictObj); + } ckfree(cd); return NULL; } -- cgit v0.12 From 56756de072eaf847bdb2025a06a551e4c6906720 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 15 Apr 2012 21:05:43 +0000 Subject: Refactor some [zlib] subcommands into their own functions --- generic/tclZlib.c | 567 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 320 insertions(+), 247 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 9b231df..f88e0e1 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -147,11 +147,15 @@ static void ConvertError(Tcl_Interp *interp, int code); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); +static int ZlibPushSubcmd(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, int mode, int format, int level, Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr, Tcl_Obj *compDictObj); static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); +static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static void ZlibTransformTimerKill(ZlibChannelData *cd); static void ZlibTransformTimerRun(ClientData clientData); static void ZlibTransformTimerSetup(ZlibChannelData *cd); @@ -1712,11 +1716,10 @@ ZlibCmd( int objc, Tcl_Obj *const objv[]) { - int command, dlen, mode, format, i, option, level = -1; + int command, dlen, i, option, level = -1; unsigned start, buffersize = 0; - Tcl_ZlibStream zh; Byte *data; - Tcl_Obj *headerDictObj, *headerVarObj; + Tcl_Obj *headerDictObj; const char *extraInfoStr = NULL; static const char *const commands[] = { "adler32", "compress", "crc32", "decompress", "deflate", "gunzip", @@ -1727,14 +1730,6 @@ ZlibCmd( CMD_ADLER, CMD_COMPRESS, CMD_CRC, CMD_DECOMPRESS, CMD_DEFLATE, CMD_GUNZIP, CMD_GZIP, CMD_INFLATE, CMD_PUSH, CMD_STREAM }; - static const char *const stream_formats[] = { - "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", - NULL - }; - enum zlibFormats { - FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, - FMT_INFLATE - }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?"); @@ -1882,8 +1877,10 @@ ZlibCmd( } return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], buffersize, NULL); - case CMD_GUNZIP: /* gunzip gzippeddata ?bufferSize? + case CMD_GUNZIP: { /* gunzip gzippeddata ?bufferSize? * -> decompressedData */ + Tcl_Obj *headerVarObj; + if (objc < 3 || objc > 5 || ((objc & 1) == 0)) { Tcl_WrongNumArgs(interp, 2, objv, "data ?-headerVar varName?"); return TCL_ERROR; @@ -1929,268 +1926,344 @@ ZlibCmd( return TCL_ERROR; } return TCL_OK; - case CMD_STREAM: { /* stream deflate/inflate/...gunzip \ + } + case CMD_STREAM: /* stream deflate/inflate/...gunzip \ * ?options...? * -> handleCmd */ - typedef struct { - const char *name; - Tcl_Obj **valueVar; - } OptDescriptor; - Tcl_Obj *compDictObj = NULL; - Tcl_Obj *gzipHeaderObj = NULL; - Tcl_Obj *levelObj = NULL; - OptDescriptor compressionOpts[] = { - { "-dictionary", &compDictObj }, - { "-level", &levelObj }, - { NULL, NULL } - }; - OptDescriptor gzipOpts[] = { - { "-dictionary", &compDictObj }, - { "-header", &gzipHeaderObj }, - { "-level", &levelObj }, - { NULL, NULL } - }; - OptDescriptor expansionOpts[] = { - { "-dictionary", &compDictObj }, - { NULL, NULL } - }; - OptDescriptor *desc; - - if (objc < 3 || !(objc & 1)) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?-option value...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum zlibFormats) format) { - case FMT_DEFLATE: - desc = compressionOpts; - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_INFLATE: - desc = expansionOpts; - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_COMPRESS: - desc = compressionOpts; - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_DECOMPRESS: - desc = expansionOpts; - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_GZIP: - desc = gzipOpts; - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - case FMT_GUNZIP: - desc = expansionOpts; - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - } + return ZlibStreamSubcmd(interp, objc, objv); + case CMD_PUSH: /* push mode channel options... + * -> channel */ + return ZlibPushSubcmd(interp, objc, objv); + }; - for (i=3 ; i 9) { - goto badLevel; - } - } + if (objc < 3 || !(objc & 1)) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?-option value...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, + &format) != TCL_OK) { + return TCL_ERROR; + } - if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj, - &zh) != TCL_OK) { - return TCL_ERROR; - } - if (compDictObj != NULL) { - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zh; + /* + * The format determines the compression mode and the options that may be + * specified. + */ - zshPtr->compDictObj = compDictObj; - Tcl_IncrRefCount(compDictObj); - } - Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); - return TCL_OK; + switch ((enum zlibFormats) format) { + case FMT_DEFLATE: + desc = compressionOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_INFLATE: + desc = expansionOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_COMPRESS: + desc = compressionOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_DECOMPRESS: + desc = expansionOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_GZIP: + desc = gzipOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + case FMT_GUNZIP: + desc = expansionOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + default: + Tcl_AppendResult(interp, "IMPOSSIBLE", NULL); + return TCL_ERROR; } - case CMD_PUSH: { /* push mode channel options... - * -> channel */ - Tcl_Channel chan; - int chanMode; - static const char *const pushOptions[] = { - "-header", "-level", "-limit", - NULL - }; - enum pushOptions {poHeader, poLevel, poLimit}; - Tcl_Obj *headerObj = NULL; - int limit = 1, dummy; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum zlibFormats) format) { - case FMT_DEFLATE: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_INFLATE: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_COMPRESS: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_DECOMPRESS: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_GZIP: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - case FMT_GUNZIP: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - default: - Tcl_AppendResult(interp, "IMPOSSIBLE", NULL); - return TCL_ERROR; - } + /* + * Parse the options. + */ - if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, - 0) != TCL_OK) { + for (i=3 ; i 9) { + Tcl_AppendResult(interp, "level must be 0 to 9", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); + Tcl_AddErrorInfo(interp, "\n (in -level option)"); + return TCL_ERROR; + } + + /* + * Construct the stream now we know its configuration. + */ + + if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj, + &zh) != TCL_OK) { + return TCL_ERROR; + } + if (compDictObj != NULL) { + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zh; + + zshPtr->compDictObj = compDictObj; + Tcl_IncrRefCount(compDictObj); + } + Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ZlibPushSubcmd -- + * + * Implementation of the [zlib push] subcommand. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibPushSubcmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *const stream_formats[] = { + "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", + NULL + }; + enum zlibFormats { + FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, + FMT_INFLATE + }; + Tcl_Channel chan; + int chanMode, format, mode, level, i, option; + static const char *const pushOptions[] = { + "-header", "-level", "-limit", NULL + }; + enum pushOptions {poHeader, poLevel, poLimit}; + Tcl_Obj *headerObj = NULL; + int limit = 1, dummy; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, + &format) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum zlibFormats) format) { + case FMT_DEFLATE: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_INFLATE: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_COMPRESS: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_DECOMPRESS: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_GZIP: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + case FMT_GUNZIP: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + default: + Tcl_AppendResult(interp, "IMPOSSIBLE", NULL); + return TCL_ERROR; + } + + if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK){ + return TCL_ERROR; + } + + /* + * Sanity checks. + */ + + if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) { + Tcl_AppendResult(interp, + "compression may only be applied to writable channels", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL); + return TCL_ERROR; + } + if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { + Tcl_AppendResult(interp, + "decompression may only be applied to readable channels", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL); + return TCL_ERROR; + } + + /* + * Parse options. + */ + + level = Z_DEFAULT_COMPRESSION; + for (i=4 ; i objc-1) { + Tcl_AppendResult(interp, "value missing for -header option", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } - switch ((enum pushOptions) option) { - case poHeader: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -header option", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - headerObj = objv[i]; - if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -header option)"); - return TCL_ERROR; - } - break; - case poLevel: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -level option", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i], - (int *) &level) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -level option)"); - return TCL_ERROR; - } - if (level < 0 || level > 9) { - extraInfoStr = "\n (in -level option)"; - goto badLevel; - } - break; - case poLimit: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -limit option", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i], - (int *) &limit) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -limit option)"); - return TCL_ERROR; - } - if (limit < 1) { - limit = 1; - } - break; + headerObj = objv[i]; + if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (in -header option)"); + return TCL_ERROR; } + break; + case poLevel: + if (++i > objc-1) { + Tcl_AppendResult(interp, + "value missing for -level option", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[i], (int*) &level) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (in -level option)"); + return TCL_ERROR; + } + if (level < 0 || level > 9) { + Tcl_AppendResult(interp, "level must be 0 to 9", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", + NULL); + Tcl_AddErrorInfo(interp, "\n (in -level option)"); + return TCL_ERROR; + } + break; + case poLimit: + if (++i > objc-1) { + Tcl_AppendResult(interp, "value missing for -limit option", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[i], (int*) &limit) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (in -limit option)"); + return TCL_ERROR; + } + if (limit < 1) { + limit = 1; + } + break; } - - if (ZlibStackChannelTransform(interp, mode, format, level, chan, - headerObj, NULL) == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[3]); - return TCL_OK; } - }; - - return TCL_ERROR; - badLevel: - Tcl_AppendResult(interp, "level must be 0 to 9", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); - if (extraInfoStr) { - Tcl_AddErrorInfo(interp, extraInfoStr); + if (ZlibStackChannelTransform(interp, mode, format, level, chan, + headerObj, NULL) == NULL) { + return TCL_ERROR; } - return TCL_ERROR; - badBuffer: - Tcl_AppendResult(interp, "buffer size must be 32 to 65536", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, objv[3]); + return TCL_OK; } /* -- cgit v0.12 From dab3544492a61dfdc8c9aae062b9490c643a417f Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 17 Apr 2012 07:42:58 +0000 Subject: Working towards the channel transform config options. --- generic/tclZlib.c | 30 ++++++++++++++++++++++++++---- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index f88e0e1..0caa02b 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2130,10 +2130,10 @@ ZlibPushSubcmd( Tcl_Channel chan; int chanMode, format, mode, level, i, option; static const char *const pushOptions[] = { - "-header", "-level", "-limit", NULL + "-dictionary", "-header", "-level", "-limit", NULL }; - enum pushOptions {poHeader, poLevel, poLimit}; - Tcl_Obj *headerObj = NULL; + enum pushOptions {poDictionary, poHeader, poLevel, poLimit}; + Tcl_Obj *headerObj = NULL, *compDictObj = NULL; int limit = 1, dummy; if (objc < 4) { @@ -2255,6 +2255,15 @@ ZlibPushSubcmd( limit = 1; } break; + case poDictionary: + if (++i > objc-1) { + Tcl_AppendResult(interp, + "value missing for -dictionary option", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[i]; + break; } } @@ -2262,6 +2271,10 @@ ZlibPushSubcmd( headerObj, NULL) == NULL) { return TCL_ERROR; } + if ((compDictObj != NULL) && (Tcl_SetChannelOption(interp, chan, + "-dictionary", TclGetString(compDictObj)) != TCL_OK)) { + return TCL_ERROR; + } Tcl_SetObjResult(interp, objv[3]); return TCL_OK; } @@ -2742,7 +2755,16 @@ ZlibTransformSetOption( /* not used */ int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE); if (optionName && strcmp(optionName, "-dictionary") == 0) { - // TODO dictionary option + Tcl_Obj *compDictObj; + + TclNewStringObj(compDictObj, value, strlen(value)); + Tcl_IncrRefCount(compDictObj); + (void) Tcl_GetByteArrayFromObj(compDictObj, NULL); + if (cd->compDictObj) { + TclDecrRefCount(cd->compDictObj); + } + cd->compDictObj = compDictObj; + // TODO: consider whether to apply immediately } if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) { -- cgit v0.12 From ec9c29c80dd663668c326a4008a2f78696e76c93 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 18 Apr 2012 18:42:54 +0000 Subject: Experimental branch where the interp->result field and related are removed and all simplifications that makes possible are done. Seems this can at best be a Tcl 9 reform. --- generic/tcl.h | 16 +++++++++------- generic/tclBasic.c | 42 +++++++++++++++++++++++++++++++++++------- generic/tclHistory.c | 2 ++ generic/tclInt.h | 15 +++++++++++++++ generic/tclResult.c | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclStubLib.c | 8 +++++++- generic/tclTest.c | 13 +++++++++++++ generic/tclUtil.c | 13 +++++++++++++ 8 files changed, 146 insertions(+), 15 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 729e521..46266d2 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -499,7 +499,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; * Instead, they set a Tcl_Obj member in the "real" structure that can be * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ - +#if 0 typedef struct Tcl_Interp { /* TIP #330: Strongly discourage extensions from using the string * result. */ @@ -529,6 +529,8 @@ typedef struct Tcl_Interp { int unused5 TCL_DEPRECATED_API("bad field access"); #endif } Tcl_Interp; +#endif +typedef struct Tcl_Interp Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; @@ -870,13 +872,13 @@ int Tcl_IsShared(Tcl_Obj *objPtr); */ typedef struct Tcl_SavedResult { - char *result; - Tcl_FreeProc *freeProc; + char *unused1; + Tcl_FreeProc *unused2; Tcl_Obj *objResultPtr; - char *appendResult; - int appendAvl; - int appendUsed; - char resultSpace[TCL_RESULT_SIZE+1]; + char *unused3; + int unused4; + int unused5; + char unused6[TCL_RESULT_SIZE+1]; } Tcl_SavedResult; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e09ea1e..d55faeb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -503,8 +503,10 @@ Tcl_CreateInterp(void) iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; +#if 0 iPtr->result = iPtr->resultSpace; iPtr->freeProc = NULL; +#endif iPtr->errorLine = 0; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); @@ -560,9 +562,11 @@ Tcl_CreateInterp(void) iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; +#if 0 iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; +#endif Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; @@ -591,7 +595,9 @@ Tcl_CreateInterp(void) iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); +#if 0 iPtr->resultSpace[0] = 0; +#endif iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -1493,7 +1499,9 @@ DeleteInterpProc( */ Tcl_FreeResult(interp); +#if 0 iPtr->result = NULL; +#endif Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); @@ -1515,10 +1523,12 @@ DeleteInterpProc( if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } +#if 0 if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; } +#endif TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); @@ -2385,7 +2395,7 @@ TclInvokeStringCommand( * in the Command structure. * * Results: - * A standard Tcl string result value. + * A standard Tcl result value. * * Side effects: * Besides those side effects of the called Tcl_CmdProc, @@ -2425,12 +2435,14 @@ TclInvokeObjectCommand( cmdPtr->objClientData, argc, objv); } +#if 0 /* * Move the interpreter's object result to the string result, then reset * the object result. */ (void) Tcl_GetStringResult(interp); +#endif /* * Decrement the ref counts for the argument objects created above, then @@ -3800,7 +3812,7 @@ Tcl_ListMathFuncs( * otherwise. * * Side effects: - * The interpreters object and string results are cleared. + * The interpreter's result is cleared. * *---------------------------------------------------------------------- */ @@ -3812,8 +3824,8 @@ TclInterpReady( register Interp *iPtr = (Interp *) interp; /* - * Reset both the interpreter's string and object results and clear out - * any previous error information. + * Reset the interpreter's result and clear out any previous error + * information. */ Tcl_ResetResult(interp); @@ -4333,10 +4345,11 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { - Interp *iPtr = (Interp *) interp; +/* Interp *iPtr = (Interp *) interp;*/ NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; +#if 0 /* * If the interpreter has a non-empty string result, the result object is * either empty or stale because some function set interp->result @@ -4350,6 +4363,7 @@ TclNRRunCallbacks( if (*(iPtr->result) != 0) { (void) Tcl_GetObjResult(interp); } +#endif while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); @@ -5828,6 +5842,7 @@ Tcl_Eval( * previous call to Tcl_CreateInterp). */ const char *script) /* Pointer to TCL command to execute. */ { +#if 0 int code = Tcl_EvalEx(interp, script, -1, 0); /* @@ -5838,6 +5853,8 @@ Tcl_Eval( (void) Tcl_GetStringResult(interp); return code; +#endif + return Tcl_EvalEx(interp, script, -1, 0); } /* @@ -6335,9 +6352,11 @@ Tcl_ExprLong( Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); +#if 0 if (result != TCL_OK) { (void) Tcl_GetStringResult(interp); } +#endif } return result; } @@ -6364,9 +6383,11 @@ Tcl_ExprDouble( result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* Discard the expression object. */ +#if 0 if (result != TCL_OK) { (void) Tcl_GetStringResult(interp); } +#endif } return result; } @@ -6392,6 +6413,7 @@ Tcl_ExprBoolean( Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); +#if 0 if (result != TCL_OK) { /* * Move the interpreter's object result to the string result, then @@ -6400,6 +6422,7 @@ Tcl_ExprBoolean( (void) Tcl_GetStringResult(interp); } +#endif return result; } } @@ -6724,12 +6747,13 @@ Tcl_ExprString( Tcl_DecrRefCount(resultPtr); } } - +#if 0 /* * Force the string rep of the interp result. */ (void) Tcl_GetStringResult(interp); +#endif return code; } @@ -6833,6 +6857,7 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { +#if 0 if (iPtr->result[0] != 0) { /* * The interp's string result is set, apparently by some extension @@ -6844,8 +6869,11 @@ Tcl_AddObjErrorInfo( iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); } else { +#endif iPtr->errorInfo = iPtr->objResultPtr; +#if 0 } +#endif Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); @@ -6923,7 +6951,7 @@ Tcl_VarEvalVA( * * Results: * A standard Tcl return result. An error message or other result may be - * left in interp->result. + * left in the interp. * * Side effects: * Depends on what was done by the command. diff --git a/generic/tclHistory.c b/generic/tclHistory.c index b10d423..5448365 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -74,12 +74,14 @@ Tcl_RecordAndEval( Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); +#if 0 /* * Move the interpreter's object result to the string result, then * reset the object result. */ (void) Tcl_GetStringResult(interp); +#endif /* * Discard the Tcl object created to hold the command. diff --git a/generic/tclInt.h b/generic/tclInt.h index 08b3f70..0d541a8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1811,6 +1811,7 @@ typedef struct Interp { * Tcl_GetStringResult. See the SetResult man page for details. */ +#if 0 char *result; /* If the last command returned a string * result, this points to it. Should not be * accessed directly; see comment above. */ @@ -1821,6 +1822,10 @@ typedef struct Interp { * address of procedure to invoke to free the * string result. Tcl_Eval must free it before * executing next command. */ +#else + char *unused3; + Tcl_FreeProc *unused4; +#endif int errorLine; /* When TCL_ERROR is returned, this gives the * line number in the command where the error * occurred (1 means first line). */ @@ -1878,6 +1883,7 @@ typedef struct Interp { * See Tcl_AppendResult code for details. */ +#if 0 char *appendResult; /* Storage space for results generated by * Tcl_AppendResult. Ckalloc-ed. NULL means * not yet allocated. */ @@ -1885,6 +1891,11 @@ typedef struct Interp { * partialResult. */ int appendUsed; /* Number of non-null bytes currently stored * at partialResult. */ +#else + char *unused5; + int unused6; + int unused7; +#endif /* * Information about packages. Used only in tclPkg.c. @@ -1946,8 +1957,12 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ +#if 0 char resultSpace[TCL_RESULT_SIZE+1]; /* Static space holding small results. */ +#else + char unused8[TCL_RESULT_SIZE+1]; +#endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ diff --git a/generic/tclResult.c b/generic/tclResult.c index 4443cc1..cbaefcb 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -27,7 +27,9 @@ enum returnKeys { static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); +#if 0 static void SetupAppendBuffer(Interp *iPtr, int newSpace); +#endif /* * This structure is used to take a snapshot of the interpreter state in @@ -247,6 +249,7 @@ Tcl_SaveResult( iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); +#if 0 /* * Save the string result. */ @@ -284,6 +287,7 @@ Tcl_SaveResult( iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; iPtr->freeProc = 0; +#endif } /* @@ -313,6 +317,7 @@ Tcl_RestoreResult( Tcl_ResetResult(interp); +#if 0 /* * Restore the string result. */ @@ -345,6 +350,7 @@ Tcl_RestoreResult( iPtr->result = statePtr->result; } +#endif /* * Restore the object result. @@ -378,6 +384,7 @@ Tcl_DiscardResult( { TclDecrRefCount(statePtr->objResultPtr); +#if 0 if (statePtr->result == statePtr->appendResult) { ckfree(statePtr->appendResult); } else if (statePtr->freeProc) { @@ -387,6 +394,7 @@ Tcl_DiscardResult( statePtr->freeProc(statePtr->result); } } +#endif } /* @@ -416,6 +424,7 @@ Tcl_SetResult( * TCL_STATIC, TCL_VOLATILE, or the address of * a Tcl_FreeProc such as free. */ { +#if 0 Interp *iPtr = (Interp *) interp; register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; char *oldResult = iPtr->result; @@ -459,6 +468,17 @@ Tcl_SetResult( */ ResetObjResult(iPtr); +#else + Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); + if (result == NULL || freeProc == NULL || freeProc == TCL_VOLATILE) { + return; + } + if (freeProc == TCL_DYNAMIC) { + ckfree(result); + } else { + (*freeProc)(result); + } +#endif } /* @@ -482,6 +502,7 @@ const char * Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { +#if 0 /* * If the string result is empty, move the object result to the string * result, then reset the object result. @@ -494,6 +515,10 @@ Tcl_GetStringResult( TCL_VOLATILE); } return iPtr->result; +#else + Interp *iPtr = (Interp *)interp; + return Tcl_GetString(iPtr->objResultPtr); +#endif } /* @@ -535,6 +560,7 @@ Tcl_SetObjResult( TclDecrRefCount(oldObjResult); +#if 0 /* * Reset the string result since we just set the result object. */ @@ -549,6 +575,7 @@ Tcl_SetObjResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif } /* @@ -577,6 +604,7 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; +#if 0 Tcl_Obj *objResultPtr; int length; @@ -603,6 +631,7 @@ Tcl_GetObjResult( iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; } +#endif return iPtr->objResultPtr; } @@ -721,6 +750,7 @@ Tcl_AppendElement( * to result. */ { Interp *iPtr = (Interp *) interp; +#if 0 char *dst; int size; int flags; @@ -764,7 +794,24 @@ Tcl_AppendElement( flags |= TCL_DONT_QUOTE_HASH; } iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); +#else + Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); + Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); + int length; + const char *bytes; + + if (Tcl_IsShared(iPtr->objResultPtr)) { + Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); + } + bytes = Tcl_GetStringFromObj(iPtr->objResultPtr, &length); + if (TclNeedSpace(bytes, bytes+length)) { + Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); + } + Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); + Tcl_DecrRefCount(listPtr); +#endif } +#if 0 /* *---------------------------------------------------------------------- @@ -845,6 +892,7 @@ SetupAppendBuffer( Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } +#endif /* *---------------------------------------------------------------------- @@ -874,6 +922,7 @@ Tcl_FreeResult( { register Interp *iPtr = (Interp *) interp; +#if 0 if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -882,6 +931,7 @@ Tcl_FreeResult( } iPtr->freeProc = 0; } +#endif ResetObjResult(iPtr); } @@ -912,6 +962,7 @@ Tcl_ResetResult( register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); +#if 0 if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -922,6 +973,7 @@ Tcl_ResetResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index f569820..71933a0 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -41,10 +41,16 @@ HasStubSupport( if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) { return iPtr->stubTable; } - +#if 0 iPtr->result = (char *)"This interpreter does not support stubs-enabled extensions."; iPtr->freeProc = TCL_STATIC; +#else + Tcl_Obj errorMsg = {2, + "This interpreter does not support stubs-enabled extensions.", + 59, NULL, {0}}; + iPtr->objResultPtr = &errorMsg; +#endif return NULL; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 37ec751..1a189c7 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -120,12 +120,14 @@ typedef struct TclEncoding { char *fromUtfCmd; } TclEncoding; +#if 0 /* * The counter below is used to determine if the TestsaveresultFree routine * was called for a result. */ static int freeCount; +#endif /* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. @@ -5063,7 +5065,9 @@ TestsaveresultCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { +#if 0 Interp* iPtr = (Interp*) interp; +#endif int discard, result, index; Tcl_SavedResult state; Tcl_Obj *objPtr; @@ -5114,7 +5118,9 @@ TestsaveresultCmd( break; } +#if 0 freeCount = 0; +#endif Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { @@ -5132,11 +5138,16 @@ TestsaveresultCmd( switch ((enum options) index) { case RESULT_DYNAMIC: { +#if 0 int present = iPtr->freeProc == TestsaveresultFree; int called = freeCount; Tcl_AppendElement(interp, called ? "called" : "notCalled"); Tcl_AppendElement(interp, present ? "present" : "missing"); +#else + Tcl_AppendElement(interp, discard ? "called" : "notCalled"); + Tcl_AppendElement(interp, !discard ? "present" : "missing"); +#endif break; } case RESULT_OBJECT: @@ -5169,7 +5180,9 @@ static void TestsaveresultFree( char *blockPtr) { +#if 0 freeCount++; +#endif } /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index a1c1996..32b1bfe 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2626,6 +2626,7 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { +#if 0 Interp *iPtr = (Interp *) interp; Tcl_ResetResult(interp); @@ -2637,8 +2638,11 @@ Tcl_DStringResult( iPtr->result = iPtr->resultSpace; memcpy(iPtr->result, dsPtr->string, dsPtr->length + 1); } else { +#endif Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); +#if 0 } +#endif dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; @@ -2672,6 +2676,7 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { +#if 0 Interp *iPtr = (Interp *) interp; if (dsPtr->string != dsPtr->staticSpace) { @@ -2710,6 +2715,14 @@ Tcl_DStringGetResult( iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#else + int length; + char *bytes = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + + Tcl_DStringFree(dsPtr); + Tcl_DStringAppend(dsPtr, bytes, length); + Tcl_ResetResult(interp); +#endif } /* -- cgit v0.12 From ac3d0b69d31e29cb0c279560444cd995a032d2b7 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Apr 2012 12:41:06 +0000 Subject: Clean version of changes; ifdef-free --- generic/tcl.h | 32 +---- generic/tclBasic.c | 105 +-------------- generic/tclHistory.c | 9 -- generic/tclInt.h | 43 +------ generic/tclResult.c | 358 +-------------------------------------------------- generic/tclStubLib.c | 14 +- generic/tclTest.c | 30 +---- generic/tclUtil.c | 59 +-------- 8 files changed, 22 insertions(+), 628 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 46266d2..a7d3917 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -499,37 +499,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; * Instead, they set a Tcl_Obj member in the "real" structure that can be * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ -#if 0 -typedef struct Tcl_Interp { - /* TIP #330: Strongly discourage extensions from using the string - * result. */ -#ifdef USE_INTERP_RESULT - char *result TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); - /* If the last command returned a string - * result, this points to it. */ - void (*freeProc) (char *blockPtr) - TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); - /* Zero means the string result is statically - * allocated. TCL_DYNAMIC means it was - * allocated with ckalloc and should be freed - * with ckfree. Other values give the address - * of function to invoke to free the result. - * Tcl_Eval must free it before executing next - * command. */ -#else - char *unused3 TCL_DEPRECATED_API("bad field access"); - void (*unused4) (char *) TCL_DEPRECATED_API("bad field access"); -#endif -#ifdef USE_INTERP_ERRORLINE - int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); - /* When TCL_ERROR is returned, this gives the - * line number within the command where the - * error occurred (1 if first line). */ -#else - int unused5 TCL_DEPRECATED_API("bad field access"); -#endif -} Tcl_Interp; -#endif + typedef struct Tcl_Interp Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d55faeb..a66b8b2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -503,10 +503,6 @@ Tcl_CreateInterp(void) iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; -#if 0 - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = NULL; -#endif iPtr->errorLine = 0; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); @@ -562,12 +558,6 @@ Tcl_CreateInterp(void) iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; -#if 0 - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - iPtr->appendUsed = 0; -#endif - Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; @@ -595,9 +585,6 @@ Tcl_CreateInterp(void) iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); -#if 0 - iPtr->resultSpace[0] = 0; -#endif iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -1499,9 +1486,6 @@ DeleteInterpProc( */ Tcl_FreeResult(interp); -#if 0 - iPtr->result = NULL; -#endif Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); @@ -1523,12 +1507,6 @@ DeleteInterpProc( if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } -#if 0 - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - } -#endif TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); @@ -2435,15 +2413,6 @@ TclInvokeObjectCommand( cmdPtr->objClientData, argc, objv); } -#if 0 - /* - * Move the interpreter's object result to the string result, then reset - * the object result. - */ - - (void) Tcl_GetStringResult(interp); -#endif - /* * Decrement the ref counts for the argument objects created above, then * free the objv array if malloc'ed storage was used. @@ -4345,26 +4314,9 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { -/* Interp *iPtr = (Interp *) interp;*/ NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; -#if 0 - /* - * If the interpreter has a non-empty string result, the result object is - * either empty or stale because some function set interp->result - * directly. If so, move the string result to the result object, then - * reset the string result. - * - * This only needs to be done for the first item in the list: all other - * are for NR function calls, and those are Tcl_Obj based. - */ - - if (*(iPtr->result) != 0) { - (void) Tcl_GetObjResult(interp); - } -#endif - while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); procPtr = callbackPtr->procPtr; @@ -5842,18 +5794,6 @@ Tcl_Eval( * previous call to Tcl_CreateInterp). */ const char *script) /* Pointer to TCL command to execute. */ { -#if 0 - int code = Tcl_EvalEx(interp, script, -1, 0); - - /* - * For backwards compatibility with old C code that predates the object - * system in Tcl 8.0, we have to mirror the object result back into the - * string result (some callers may expect it there). - */ - - (void) Tcl_GetStringResult(interp); - return code; -#endif return Tcl_EvalEx(interp, script, -1, 0); } @@ -6352,11 +6292,6 @@ Tcl_ExprLong( Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); -#if 0 - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); - } -#endif } return result; } @@ -6383,11 +6318,6 @@ Tcl_ExprDouble( result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* Discard the expression object. */ -#if 0 - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); - } -#endif } return result; } @@ -6413,16 +6343,6 @@ Tcl_ExprBoolean( Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); -#if 0 - if (result != TCL_OK) { - /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - } -#endif return result; } } @@ -6747,13 +6667,6 @@ Tcl_ExprString( Tcl_DecrRefCount(resultPtr); } } -#if 0 - /* - * Force the string rep of the interp result. - */ - - (void) Tcl_GetStringResult(interp); -#endif return code; } @@ -6857,23 +6770,7 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { -#if 0 - if (iPtr->result[0] != 0) { - /* - * The interp's string result is set, apparently by some extension - * making a deprecated direct write to it. That extension may - * expect interp->result to continue to be set, so we'll take - * special pains to avoid clearing it, until we drop support for - * interp->result completely. - */ - - iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); - } else { -#endif - iPtr->errorInfo = iPtr->objResultPtr; -#if 0 - } -#endif + iPtr->errorInfo = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 5448365..c44ba4c 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -74,15 +74,6 @@ Tcl_RecordAndEval( Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); -#if 0 - /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - - (void) Tcl_GetStringResult(interp); -#endif - /* * Discard the Tcl object created to hold the command. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 0d541a8..fa7c03c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1800,32 +1800,16 @@ typedef struct Interp { * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the * other. * - * The interpreter's result is held in both the string and the - * objResultPtr fields. These fields hold, respectively, the result's - * string or object value. The interpreter's result is always in the - * result field if that is non-empty, otherwise it is in objResultPtr. - * The two fields are kept consistent unless some C code sets - * interp->result directly. Programs should not access result and - * objResultPtr directly; instead, they should always get and set the - * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and - * Tcl_GetStringResult. See the SetResult man page for details. + * The interpreter's result is held in the objResultPtr field. This field + * holds the result's object value. The interpreter's result is always in + * objResultPtr. Programs should not access objResultPtr directly; + * instead, they should always get and set the result using procedures + * such as Tcl_SetObjResult, Tcl_GetObjResult, and Tcl_GetStringResult. + * See the SetResult man page for details. */ -#if 0 - char *result; /* If the last command returned a string - * result, this points to it. Should not be - * accessed directly; see comment above. */ - Tcl_FreeProc *freeProc; /* Zero means a string result is statically - * allocated. TCL_DYNAMIC means string result - * was allocated with ckalloc and should be - * freed with ckfree. Other values give - * address of procedure to invoke to free the - * string result. Tcl_Eval must free it before - * executing next command. */ -#else char *unused3; Tcl_FreeProc *unused4; -#endif int errorLine; /* When TCL_ERROR is returned, this gives the * line number in the command where the error * occurred (1 means first line). */ @@ -1883,19 +1867,9 @@ typedef struct Interp { * See Tcl_AppendResult code for details. */ -#if 0 - char *appendResult; /* Storage space for results generated by - * Tcl_AppendResult. Ckalloc-ed. NULL means - * not yet allocated. */ - int appendAvl; /* Total amount of space available at - * partialResult. */ - int appendUsed; /* Number of non-null bytes currently stored - * at partialResult. */ -#else char *unused5; int unused6; int unused7; -#endif /* * Information about packages. Used only in tclPkg.c. @@ -1957,12 +1931,7 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ -#if 0 - char resultSpace[TCL_RESULT_SIZE+1]; - /* Static space holding small results. */ -#else char unused8[TCL_RESULT_SIZE+1]; -#endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ diff --git a/generic/tclResult.c b/generic/tclResult.c index cbaefcb..693c650 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -27,9 +27,6 @@ enum returnKeys { static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); -#if 0 -static void SetupAppendBuffer(Interp *iPtr, int newSpace); -#endif /* * This structure is used to take a snapshot of the interpreter state in @@ -248,46 +245,6 @@ Tcl_SaveResult( statePtr->objResultPtr = iPtr->objResultPtr; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); - -#if 0 - /* - * Save the string result. - */ - - statePtr->freeProc = iPtr->freeProc; - if (iPtr->result == iPtr->resultSpace) { - /* - * Copy the static string data out of the interp buffer. - */ - - statePtr->result = statePtr->resultSpace; - strcpy(statePtr->result, iPtr->result); - statePtr->appendResult = NULL; - } else if (iPtr->result == iPtr->appendResult) { - /* - * Move the append buffer out of the interp. - */ - - statePtr->appendResult = iPtr->appendResult; - statePtr->appendAvl = iPtr->appendAvl; - statePtr->appendUsed = iPtr->appendUsed; - statePtr->result = statePtr->appendResult; - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - iPtr->appendUsed = 0; - } else { - /* - * Move the dynamic or static string out of the interpreter. - */ - - statePtr->result = iPtr->result; - statePtr->appendResult = NULL; - } - - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - iPtr->freeProc = 0; -#endif } /* @@ -317,41 +274,6 @@ Tcl_RestoreResult( Tcl_ResetResult(interp); -#if 0 - /* - * Restore the string result. - */ - - iPtr->freeProc = statePtr->freeProc; - if (statePtr->result == statePtr->resultSpace) { - /* - * Copy the static string data into the interp buffer. - */ - - iPtr->result = iPtr->resultSpace; - strcpy(iPtr->result, statePtr->result); - } else if (statePtr->result == statePtr->appendResult) { - /* - * Move the append buffer back into the interp. - */ - - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - } - - iPtr->appendResult = statePtr->appendResult; - iPtr->appendAvl = statePtr->appendAvl; - iPtr->appendUsed = statePtr->appendUsed; - iPtr->result = iPtr->appendResult; - } else { - /* - * Move the dynamic or static string back into the interpreter. - */ - - iPtr->result = statePtr->result; - } -#endif - /* * Restore the object result. */ @@ -383,18 +305,6 @@ Tcl_DiscardResult( Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ { TclDecrRefCount(statePtr->objResultPtr); - -#if 0 - if (statePtr->result == statePtr->appendResult) { - ckfree(statePtr->appendResult); - } else if (statePtr->freeProc) { - if (statePtr->freeProc == TCL_DYNAMIC) { - ckfree(statePtr->result); - } else { - statePtr->freeProc(statePtr->result); - } - } -#endif } /* @@ -424,51 +334,6 @@ Tcl_SetResult( * TCL_STATIC, TCL_VOLATILE, or the address of * a Tcl_FreeProc such as free. */ { -#if 0 - Interp *iPtr = (Interp *) interp; - register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; - char *oldResult = iPtr->result; - - if (result == NULL) { - iPtr->resultSpace[0] = 0; - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } else if (freeProc == TCL_VOLATILE) { - int length = strlen(result); - - if (length > TCL_RESULT_SIZE) { - iPtr->result = ckalloc(length + 1); - iPtr->freeProc = TCL_DYNAMIC; - } else { - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } - memcpy(iPtr->result, result, (unsigned) length+1); - } else { - iPtr->result = (char *) result; - iPtr->freeProc = freeProc; - } - - /* - * If the old result was dynamically-allocated, free it up. Do it here, - * rather than at the beginning, in case the new result value was part of - * the old result value. - */ - - if (oldFreeProc != 0) { - if (oldFreeProc == TCL_DYNAMIC) { - ckfree(oldResult); - } else { - oldFreeProc(oldResult); - } - } - - /* - * Reset the object result since we just set the string result. - */ - - ResetObjResult(iPtr); -#else Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); if (result == NULL || freeProc == NULL || freeProc == TCL_VOLATILE) { return; @@ -478,7 +343,6 @@ Tcl_SetResult( } else { (*freeProc)(result); } -#endif } /* @@ -502,23 +366,9 @@ const char * Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { -#if 0 - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - Interp *iPtr = (Interp *) interp; - if (*(iPtr->result) == 0) { - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - } - return iPtr->result; -#else - Interp *iPtr = (Interp *)interp; return Tcl_GetString(iPtr->objResultPtr); -#endif } /* @@ -559,23 +409,6 @@ Tcl_SetObjResult( */ TclDecrRefCount(oldObjResult); - -#if 0 - /* - * Reset the string result since we just set the result object. - */ - - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -#endif } /* @@ -604,34 +437,7 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; -#if 0 - Tcl_Obj *objResultPtr; - int length; - - /* - * If the string result is non-empty, move the string result to the object - * result, then reset the string result. - */ - if (*(iPtr->result) != 0) { - ResetObjResult(iPtr); - - objResultPtr = iPtr->objResultPtr; - length = strlen(iPtr->result); - TclInitStringRep(objResultPtr, iPtr->result, length); - - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - } -#endif return iPtr->objResultPtr; } @@ -750,51 +556,6 @@ Tcl_AppendElement( * to result. */ { Interp *iPtr = (Interp *) interp; -#if 0 - char *dst; - int size; - int flags; - - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - /* - * See how much space is needed, and grow the append buffer if needed to - * accommodate the list element. - */ - - size = Tcl_ScanElement(element, &flags) + 1; - if ((iPtr->result != iPtr->appendResult) - || (iPtr->appendResult[iPtr->appendUsed] != 0) - || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { - SetupAppendBuffer(iPtr, size+iPtr->appendUsed); - } - - /* - * Convert the string into a list element and copy it to the buffer that's - * forming, with a space separator if needed. - */ - - dst = iPtr->appendResult + iPtr->appendUsed; - if (TclNeedSpace(iPtr->appendResult, dst)) { - iPtr->appendUsed++; - *dst = ' '; - dst++; - - /* - * If we need a space to separate this element from preceding stuff, - * then this element will not lead a list, and need not have it's - * leading '#' quoted. - */ - - flags |= TCL_DONT_QUOTE_HASH; - } - iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); -#else Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); int length; @@ -809,90 +570,7 @@ Tcl_AppendElement( } Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); Tcl_DecrRefCount(listPtr); -#endif -} -#if 0 - -/* - *---------------------------------------------------------------------- - * - * SetupAppendBuffer -- - * - * This function makes sure that there is an append buffer properly - * initialized, if necessary, from the interpreter's result, and that it - * has at least enough room to accommodate newSpace new bytes of - * information. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -SetupAppendBuffer( - Interp *iPtr, /* Interpreter whose result is being set up. */ - int newSpace) /* Make sure that at least this many bytes of - * new information may be added. */ -{ - int totalSpace; - - /* - * Make the append buffer larger, if that's necessary, then copy the - * result into the append buffer and make the append buffer the official - * Tcl result. - */ - - if (iPtr->result != iPtr->appendResult) { - /* - * If an oversized buffer was used recently, then free it up so we go - * back to a smaller buffer. This avoids tying up memory forever after - * a large operation. - */ - - if (iPtr->appendAvl > 500) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - } - iPtr->appendUsed = strlen(iPtr->result); - } else if (iPtr->result[iPtr->appendUsed] != 0) { - /* - * Most likely someone has modified a result created by - * Tcl_AppendResult et al. so that it has a different size. Just - * recompute the size. - */ - - iPtr->appendUsed = strlen(iPtr->result); - } - - totalSpace = newSpace + iPtr->appendUsed; - if (totalSpace >= iPtr->appendAvl) { - char *new; - - if (totalSpace < 100) { - totalSpace = 200; - } else { - totalSpace *= 2; - } - new = ckalloc(totalSpace); - strcpy(new, iPtr->result); - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - } - iPtr->appendResult = new; - iPtr->appendAvl = totalSpace; - } else if (iPtr->result != iPtr->appendResult) { - strcpy(iPtr->appendResult, iPtr->result); - } - - Tcl_FreeResult((Tcl_Interp *) iPtr); - iPtr->result = iPtr->appendResult; } -#endif /* *---------------------------------------------------------------------- @@ -900,18 +578,17 @@ SetupAppendBuffer( * Tcl_FreeResult -- * * This function frees up the memory associated with an interpreter's - * string result. It also resets the interpreter's result object. - * Tcl_FreeResult is most commonly used when a function is about to - * replace one result value with another. + * result, resetting the interpreter's result object. Tcl_FreeResult is + * most commonly used when a function is about to replace one result + * value with another. * * Results: * None. * * Side effects: - * Frees the memory associated with interp's string result and sets - * interp->freeProc to zero, but does not change interp->result or clear - * error state. Resets interp's result object to an unshared empty - * object. + * Frees the memory associated with interp's result but does not change + * any part of the error dictionary (i.e., the errorinfo and errorcode + * remain the same). * *---------------------------------------------------------------------- */ @@ -922,17 +599,6 @@ Tcl_FreeResult( { register Interp *iPtr = (Interp *) interp; -#if 0 - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } -#endif - ResetObjResult(iPtr); } @@ -962,18 +628,6 @@ Tcl_ResetResult( register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); -#if 0 - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -#endif if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 71933a0..b36627c 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -37,20 +37,16 @@ HasStubSupport( Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; + static Tcl_Obj errorMsg = { + 2, /* Stop anything from trying to deallocate this memory! */ + "This interpreter does not support stubs-enabled extensions.", + 59, NULL, {0} + }; if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) { return iPtr->stubTable; } -#if 0 - iPtr->result = - (char *)"This interpreter does not support stubs-enabled extensions."; - iPtr->freeProc = TCL_STATIC; -#else - Tcl_Obj errorMsg = {2, - "This interpreter does not support stubs-enabled extensions.", - 59, NULL, {0}}; iPtr->objResultPtr = &errorMsg; -#endif return NULL; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 1a189c7..b407f51 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -120,15 +120,6 @@ typedef struct TclEncoding { char *fromUtfCmd; } TclEncoding; -#if 0 -/* - * The counter below is used to determine if the TestsaveresultFree routine - * was called for a result. - */ - -static int freeCount; -#endif - /* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. */ @@ -5065,9 +5056,6 @@ TestsaveresultCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { -#if 0 - Interp* iPtr = (Interp*) interp; -#endif int discard, result, index; Tcl_SavedResult state; Tcl_Obj *objPtr; @@ -5118,9 +5106,6 @@ TestsaveresultCmd( break; } -#if 0 - freeCount = 0; -#endif Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { @@ -5137,19 +5122,10 @@ TestsaveresultCmd( } switch ((enum options) index) { - case RESULT_DYNAMIC: { -#if 0 - int present = iPtr->freeProc == TestsaveresultFree; - int called = freeCount; - - Tcl_AppendElement(interp, called ? "called" : "notCalled"); - Tcl_AppendElement(interp, present ? "present" : "missing"); -#else + case RESULT_DYNAMIC: Tcl_AppendElement(interp, discard ? "called" : "notCalled"); Tcl_AppendElement(interp, !discard ? "present" : "missing"); -#endif break; - } case RESULT_OBJECT: Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr ? "same" : "different"); @@ -5180,9 +5156,7 @@ static void TestsaveresultFree( char *blockPtr) { -#if 0 - freeCount++; -#endif + /* empty... */ } /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 32b1bfe..f316dfb 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2626,23 +2626,7 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { -#if 0 - Interp *iPtr = (Interp *) interp; - - Tcl_ResetResult(interp); - - if (dsPtr->string != dsPtr->staticSpace) { - iPtr->result = dsPtr->string; - iPtr->freeProc = TCL_DYNAMIC; - } else if (dsPtr->length < TCL_RESULT_SIZE) { - iPtr->result = iPtr->resultSpace; - memcpy(iPtr->result, dsPtr->string, dsPtr->length + 1); - } else { -#endif - Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); -#if 0 - } -#endif + Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; @@ -2676,53 +2660,12 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { -#if 0 - Interp *iPtr = (Interp *) interp; - - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); - } - - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - dsPtr->length = strlen(iPtr->result); - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - dsPtr->string = iPtr->result; - dsPtr->spaceAvl = dsPtr->length+1; - } else { - dsPtr->string = ckalloc(dsPtr->length+1); - memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); - iPtr->freeProc(iPtr->result); - } - dsPtr->spaceAvl = dsPtr->length+1; - iPtr->freeProc = NULL; - } else { - if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { - dsPtr->string = dsPtr->staticSpace; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - } else { - dsPtr->string = ckalloc(dsPtr->length+1); - dsPtr->spaceAvl = dsPtr->length + 1; - } - memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); - } - - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -#else int length; char *bytes = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); Tcl_DStringFree(dsPtr); Tcl_DStringAppend(dsPtr, bytes, length); Tcl_ResetResult(interp); -#endif } /* -- cgit v0.12 From 68191ded75fa06a222a1c4b936d7d12f7f8d69eb Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Apr 2012 12:57:45 +0000 Subject: To preserve the ability of [load] to bring in mistmatched stubs-enabled modules and react with an error rather than a crash, HasStubSupport() has to keep fiddling with the same fields as always. --- generic/tclStubLib.c | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index b36627c..9e9208d 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -37,16 +37,13 @@ HasStubSupport( Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; - static Tcl_Obj errorMsg = { - 2, /* Stop anything from trying to deallocate this memory! */ - "This interpreter does not support stubs-enabled extensions.", - 59, NULL, {0} - }; if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) { return iPtr->stubTable; } - iPtr->objResultPtr = &errorMsg; + iPtr->unused3 + = "This interpreter does not support stubs-enabled extensions."; + iPtr->unused4 = TCL_STATIC; return NULL; } -- cgit v0.12 From bd225549d99654b28b5f9b3647014de5faf1af39 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 20 Apr 2012 10:22:03 +0000 Subject: another bit of fconfigure guts --- generic/tclZlib.c | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 0caa02b..6290d60 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2859,7 +2859,24 @@ ZlibTransformGetOption( } if (optionName == NULL || strcmp(optionName, "-dictionary") == 0) { - // TODO dictionary option + /* + * Embedded NUL bytes are ok; they'll be C080-encoded. + */ + + if (optionName == NULL) { + Tcl_DStringAppendElement(dsPtr, "-dictionary"); + if (cd->compDictObj) { + Tcl_DStringAppendElement(dsPtr, + Tcl_GetString(cd->compDictObj)); + } else { + Tcl_DStringAppendElement(dsPtr, ""); + } + } else { + int len; + const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); + + Tcl_DStringAppend(dsPtr, str, len); + } } /* -- cgit v0.12 From 1e58e8e42d522df38ef3a2299524fe31e204fa88 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 25 Apr 2012 21:03:58 +0000 Subject: Implement Tcl_DStringResult with call to TclDStringToObj. --- generic/tclUtil.c | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 8852a56..1e35165 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2626,12 +2626,7 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); - - dsPtr->string = dsPtr->staticSpace; - dsPtr->length = 0; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->staticSpace[0] = '\0'; + Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } /* -- cgit v0.12 From 34b81fea597222cf3a06602554251cb62a4be892 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 29 Apr 2012 07:18:30 +0000 Subject: Differentiate what options may be set by format type. --- generic/tclZlib.c | 26 +++++++++++++++++++++----- tests/zlib.test | 20 ++++++++++++++++++++ 2 files changed, 41 insertions(+), 5 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 51d6beb..a1b8afc 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -83,6 +83,9 @@ typedef struct { * for compression on output, or * TCL_ZLIB_STREAM_INFLATE for decompression * on input. */ + int format; /* What format of data is going on the wire. + * Needed so that the correct [fconfigure] + * options can be enabled. */ z_stream inStream; /* Structure used by zlib for decompression of * input. */ z_stream outStream; /* Structure used by zlib for compression of @@ -1985,7 +1988,6 @@ ZlibStreamSubcmd( { NULL, NULL } }; const OptDescriptor gzipOpts[] = { - { "-dictionary", &compDictObj }, { "-header", &gzipHeaderObj }, { "-level", &levelObj }, { NULL, NULL } @@ -2038,7 +2040,7 @@ ZlibStreamSubcmd( format = TCL_ZLIB_FORMAT_GZIP; break; case FMT_GUNZIP: - desc = expansionOpts; + desc = expansionOpts; // FIXME - get header, not set compDict mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_GZIP; break; @@ -2258,6 +2260,12 @@ ZlibPushSubcmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } + if (format == TCL_ZLIB_FORMAT_GZIP) { + Tcl_AppendResult(interp, "a compression dictionary may not " + "be set in the gzip format", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); + return TCL_ERROR; + } compDictObj = objv[i]; break; } @@ -2748,9 +2756,11 @@ ZlibTransformSetOption( /* not used */ Tcl_DriverSetOptionProc *setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent)); static const char *chanOptions = "dictionary flush"; + static const char *gzipChanOptions = "flush"; int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE); - if (optionName && strcmp(optionName, "-dictionary") == 0) { + if (optionName && (strcmp(optionName, "-dictionary") == 0) + && (cd->format != TCL_ZLIB_FORMAT_GZIP)) { Tcl_Obj *compDictObj; TclNewStringObj(compDictObj, value, strlen(value)); @@ -2809,7 +2819,11 @@ ZlibTransformSetOption( /* not used */ } if (setOptionProc == NULL) { - return Tcl_BadChannelOption(interp, optionName, chanOptions); + if (cd->format == TCL_ZLIB_FORMAT_GZIP) { + return Tcl_BadChannelOption(interp, optionName, gzipChanOptions); + } else { + return Tcl_BadChannelOption(interp, optionName, chanOptions); + } } return setOptionProc(Tcl_GetChannelInstanceData(cd->parent), interp, @@ -2854,7 +2868,8 @@ ZlibTransformGetOption( } } - if (optionName == NULL || strcmp(optionName, "-dictionary") == 0) { + if ((cd->format != TCL_ZLIB_FORMAT_GZIP) && + (optionName == NULL || strcmp(optionName, "-dictionary") == 0)) { /* * Embedded NUL bytes are ok; they'll be C080-encoded. */ @@ -3051,6 +3066,7 @@ ZlibStackChannelTransform( memset(cd, 0, sizeof(ZlibChannelData)); cd->mode = mode; + cd->format = format; if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) { if (mode == TCL_ZLIB_STREAM_DEFLATE) { diff --git a/tests/zlib.test b/tests/zlib.test index 3aaca29..017243b 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -168,6 +168,26 @@ test zlib-8.4 {transformation and flushing: Bug 3517696} -setup { catch {close $fd} removeFile $file } -result {} +test zlib-8.5 {transformation and fconfigure} -setup { + set file [makeFile {} test.z] + set fd [open $file wb] +} -constraints zlib -body { + list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \ + [chan pop $fd; fconfigure $fd] +} -cleanup { + catch {close $fd} + removeFile $file +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +test zlib-8.6 {transformation and fconfigure} -setup { + set file [makeFile {} test.gz] + set fd [open $file wb] +} -constraints zlib -body { + list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \ + [chan pop $fd; fconfigure $fd] +} -cleanup { + catch {close $fd} + removeFile $file +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From 884ea95c53a46e2e95b6b913443c1b232d0ddcd4 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 1 May 2012 08:29:11 +0000 Subject: first actual test of doing something with a compression dictionary --- generic/tclZlib.c | 16 ++++++++++------ tests/zlib.test | 15 +++++++++++++++ 2 files changed, 25 insertions(+), 6 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index a1b8afc..1fe5b05 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2272,11 +2272,7 @@ ZlibPushSubcmd( } if (ZlibStackChannelTransform(interp, mode, format, level, chan, - headerObj, NULL) == NULL) { - return TCL_ERROR; - } - if ((compDictObj != NULL) && (Tcl_SetChannelOption(interp, chan, - "-dictionary", TclGetString(compDictObj)) != TCL_OK)) { + headerObj, compDictObj) == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, objv[3]); @@ -2762,6 +2758,7 @@ ZlibTransformSetOption( /* not used */ if (optionName && (strcmp(optionName, "-dictionary") == 0) && (cd->format != TCL_ZLIB_FORMAT_GZIP)) { Tcl_Obj *compDictObj; + int code; TclNewStringObj(compDictObj, value, strlen(value)); Tcl_IncrRefCount(compDictObj); @@ -2770,7 +2767,14 @@ ZlibTransformSetOption( /* not used */ TclDecrRefCount(cd->compDictObj); } cd->compDictObj = compDictObj; - // TODO: consider whether to apply immediately + if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { + code = SetDeflateDictionary(&cd->outStream, compDictObj); + if (code != Z_OK) { + ConvertError(interp, code); + return TCL_ERROR; + } + } + return TCL_OK; } if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) { diff --git a/tests/zlib.test b/tests/zlib.test index 017243b..05b5ed5 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -188,6 +188,21 @@ test zlib-8.6 {transformation and fconfigure} -setup { catch {close $fd} removeFile $file } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +test zlib-8.7 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set msg [string repeat "am i all that i am at all? i am all that i am!" 400] + set dict "thatallam i " +} -constraints zlib -body { + zlib push compress $outSide -dictionary $dict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $msg + chan pop $outSide + string length [read $inSide] +} -cleanup { + catch {close $outSide} + catch {close $inSide} +} -result 103 test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From f2e45587d3aeaad4e51ec8cbf016682d17c9da9e Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 4 May 2012 21:18:59 +0000 Subject: Add ability to get gzip header out of streaming zlib access --- generic/tclZlib.c | 31 ++++++++++++++++++++++++++++--- 1 file changed, 28 insertions(+), 3 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 1fe5b05..be2f540 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1996,6 +1996,9 @@ ZlibStreamSubcmd( { "-dictionary", &compDictObj }, { NULL, NULL } }; + const OptDescriptor gunzipOpts[] = { + { NULL, NULL } + }; const OptDescriptor *desc; Tcl_ZlibStream zh; @@ -2040,7 +2043,7 @@ ZlibStreamSubcmd( format = TCL_ZLIB_FORMAT_GZIP; break; case FMT_GUNZIP: - desc = expansionOpts; // FIXME - get header, not set compDict + desc = gunzipOpts; mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_GZIP; break; @@ -2301,12 +2304,12 @@ ZlibStreamCmd( Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", - "fullflush", "get", "put", "reset", + "fullflush", "get", "header", "put", "reset", NULL }; enum zlibStreamCommands { zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, - zs_fullflush, zs_get, zs_put, zs_reset + zs_fullflush, zs_get, zs_header, zs_put, zs_reset }; static const char *const add_options[] = { "-buffer", "-finalize", "-flush", "-fullflush", NULL @@ -2431,6 +2434,7 @@ ZlibStreamCmd( case ao_buffer: Tcl_AppendResult(interp, "\"-buffer\" option not supported here", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); return TCL_ERROR; } if (flush == -2) { @@ -2528,6 +2532,27 @@ ZlibStreamCmd( return TCL_ERROR; } return Tcl_ZlibStreamReset(zstream); + case zs_header: { /* $strm header */ + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zstream; + Tcl_Obj *resultObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE + || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) { + Tcl_AppendResult(interp, + "only gunzip streams can produce header information", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL); + return TCL_ERROR; + } + + TclNewObj(resultObj); + ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } } return TCL_OK; -- cgit v0.12 From aae531d7801601cf2b5c9aa5b59eddca2bd37a0d Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 5 May 2012 14:29:48 +0000 Subject: start writing some documentation --- doc/zlib.n | 8 +++++++- generic/tclZlib.c | 2 +- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index 9fa83c6..6f1564c 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -1,5 +1,5 @@ '\" -'\" Copyright (c) 2008 Donal K. Fellows +'\" Copyright (c) 2008-2012 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -317,6 +317,12 @@ A short-cut for Return up to \fIcount\fR bytes from \fIstream\fR's internal buffers with the transformation applied. If \fIcount\fR is omitted, the entire contents of the buffers are returned. +. +\fIstream \fBheader\fR +. +Return the gzip header description dictionary extracted from the stream. Only +supported for streams created with their \fImode\fR parameter set to +\fBgunzip\fR. .TP \fIstream \fBput\fR ?\fIoption\fR? \fIdata\fR . diff --git a/generic/tclZlib.c b/generic/tclZlib.c index be2f540..96cda4e 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -5,7 +5,7 @@ * * Copyright (C) 2004-2005 Pascal Scheffers * Copyright (C) 2005 Unitas Software B.V. - * Copyright (c) 2008-2009 Donal K. Fellows + * Copyright (c) 2008-2012 Donal K. Fellows * * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the * public domain March 2003. -- cgit v0.12 From 720fc8cc34c3cd62f9ab5b2287cafe0420a4f1ad Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 10 May 2012 09:22:48 +0000 Subject: updated C API to be more focused on supporting just some operations --- generic/tcl.decls | 4 +++- generic/tclDecls.h | 10 +++++---- generic/tclStubInit.c | 2 +- generic/tclZlib.c | 61 +++++++++++++++++++++++++++++++++++++++++---------- 4 files changed, 59 insertions(+), 18 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index afeae51..36e92fa 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2318,8 +2318,10 @@ declare 629 { int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr) } +# TIP #400 declare 630 { - void* Tcl_ZlibStreamGetZstreamp(Tcl_ZlibStream zshandle) + void Tcl_ZlibStreamSetCompressionDictionary(Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj) } # ----- BASELINE -- FOR -- 8.6.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0c1dedf..7c3e1de 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1808,7 +1808,9 @@ EXTERN void * Tcl_FindSymbol(Tcl_Interp *interp, EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 630 */ -EXTERN void* Tcl_ZlibStreamGetZstreamp(Tcl_ZlibStream zshandle); +EXTERN void Tcl_ZlibStreamSetCompressionDictionary( + Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj); typedef struct TclStubHooks { const struct TclPlatStubs *tclPlatStubs; @@ -2474,7 +2476,7 @@ typedef struct TclStubs { int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ - void* (*tcl_ZlibStreamGetZstreamp) (Tcl_ZlibStream zshandle); /* 630 */ + void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ } TclStubs; #ifdef __cplusplus @@ -3767,8 +3769,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ -#define Tcl_ZlibStreamGetZstreamp \ - (tclStubsPtr->tcl_ZlibStreamGetZstreamp) /* 630 */ +#define Tcl_ZlibStreamSetCompressionDictionary \ + (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a74101d..7fb0f1c 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1340,7 +1340,7 @@ const TclStubs tclStubs = { Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ - Tcl_ZlibStreamGetZstreamp, /* 630 */ + Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 96cda4e..7785dea 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -67,10 +67,15 @@ typedef struct { Tcl_Obj *compDictObj; /* Byte-array object containing compression * dictionary (not dictObj!) to use if * necessary. */ + int flags; /* Miscellaneous flag bits. */ GzipHeader *gzHeaderPtr; /* If we've allocated a gzip header * structure. */ } ZlibStreamHandle; +#define DICT_TO_SET 0x1 /* If we need to set a compression dictionary + * in the low-level engine at the next + * opportunity. */ + /* * Structure used for stacked channel compression and decompression. */ @@ -606,6 +611,7 @@ Tcl_ZlibStreamInit( zshPtr->currentInput = NULL; zshPtr->streamEnd = 0; zshPtr->compDictObj = NULL; + zshPtr->flags = 0; zshPtr->gzHeaderPtr = gzHeaderPtr; memset(&zshPtr->stream, 0, sizeof(z_stream)); @@ -974,22 +980,32 @@ Tcl_ZlibStreamChecksum( /* *---------------------------------------------------------------------- * - * Tcl_ZlibStreamGetZstreamp -- + * Tcl_ZlibStreamSetCompressionDictionary -- * - * Return the z_streamp for the stream (though not typed as such, so as - * to avoid type interface poisoning). Shouldn't be used to poke around - * excessively. + * Sets the compression dictionary for a stream. This will be used as + * appropriate for the next compression or decompression action performed + * on the stream. * *---------------------------------------------------------------------- */ -void * -Tcl_ZlibStreamGetZstreamp( - Tcl_ZlibStream zshandle) +void +Tcl_ZlibStreamSetCompressionDictionary( + Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj) { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - return &zshPtr->stream; + if (compressionDictionaryObj != NULL) { + Tcl_IncrRefCount(compressionDictionaryObj); + zshPtr->flags |= DICT_TO_SET; + } else { + zshPtr->flags &= ~DICT_TO_SET; + } + if (zshPtr->compDictObj != NULL) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } + zshPtr->compDictObj = compressionDictionaryObj; } /* @@ -1028,6 +1044,17 @@ Tcl_ZlibStreamPut( zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size); zshPtr->stream.avail_in = size; + if (zshPtr->flags & DICT_TO_SET) { + e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e != Z_OK) { + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e); + } + return TCL_ERROR; + } + zshPtr->flags &= ~DICT_TO_SET; + } + /* * Deflatebound doesn't seem to take various header sizes into * account, so we add 100 extra bytes. @@ -1065,6 +1092,12 @@ Tcl_ZlibStreamPut( e = deflate(&zshPtr->stream, flush); } + if (e != Z_OK) { + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e); + } + return TCL_ERROR; + } /* * And append the final data block. @@ -3345,11 +3378,15 @@ Tcl_ZlibAdler32( return 0; } -void * -Tcl_ZlibStreamGetZstreamp( - Tcl_ZlibStream zshandle) +int +Tcl_ZlibStreamSetCompressionDictionary( + Tcl_Interp *interp, + Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj) { - return NULL; + Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); + return TCL_ERROR; } #endif /* HAVE_ZLIB */ -- cgit v0.12 From c8e8e61fcc3cfdf37937d5a91e08a126858f19a7 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 18 May 2012 00:01:58 +0000 Subject: typofix --- generic/tclZlib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 7785dea..356772e 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -991,7 +991,7 @@ Tcl_ZlibStreamChecksum( void Tcl_ZlibStreamSetCompressionDictionary( - Tcl_ZlibStream zhandle, + Tcl_ZlibStream zshandle, Tcl_Obj *compressionDictionaryObj) { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; -- cgit v0.12 From 0a40e59f2cfa986b9001aefe221bc86abf2e779a Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 5 Jun 2012 16:25:29 +0000 Subject: better test that dictionaries work --- tests/zlib.test | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/tests/zlib.test b/tests/zlib.test index 642b2a4..cc3900d 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -225,19 +225,21 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} test zlib-8.8 {transformtion and fconfigure} -setup { lassign [chan pipe] inSide outSide - set msg [string repeat "am i all that i am at all? i am all that i am!" 400] - set dict "thatallam i " + # Input is headers from fetching SPDY draft + # Dictionary is that which is proposed _in_ SPDY draft + set msg "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" + set dict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" } -constraints zlib -body { - zlib push compress $outSide -dictionary $dict + zlib push deflate $outSide -dictionary $dict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $msg chan pop $outSide - string length [read $inSide] + list [string length [zlib deflate $msg]] [string length [read $inSide]] } -cleanup { catch {close $outSide} catch {close $inSide} -} -result 103 +} -result {254 212} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From 2f46625fe9d2f2979ae73ffd9fee67ac9164c98c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 5 Jun 2012 16:36:11 +0000 Subject: fix broken tests --- generic/tclZlib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 16bed47..537fa68 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1091,7 +1091,7 @@ Tcl_ZlibStreamPut( e = deflate(&zshPtr->stream, flush); } - if (e != Z_OK) { + if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) { if (zshPtr->interp) { ConvertError(zshPtr->interp, e); } -- cgit v0.12 From bba49ba49822f55ae1b343bb8b72cd2a983247fb Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 5 Jun 2012 16:50:52 +0000 Subject: more test tinkering --- generic/tclZlib.c | 32 +++++++++++++++++++------------- tests/zlib.test | 9 ++++++--- 2 files changed, 25 insertions(+), 16 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 537fa68..333c2fa 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -146,7 +146,8 @@ static Tcl_DriverWatchProc ZlibTransformWatch; static Tcl_ObjCmdProc ZlibCmd; static Tcl_ObjCmdProc ZlibStreamCmd; -static void ConvertError(Tcl_Interp *interp, int code); +static void ConvertError(Tcl_Interp *interp, int code, + uLong adler); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); @@ -210,7 +211,8 @@ static void ConvertError( Tcl_Interp *interp, /* Interpreter to store the error in. May be * NULL, in which case nothing happens. */ - int code) /* The zlib error code. */ + int code, /* The zlib error code. */ + uLong adler) /* The checksum expected (for Z_NEED_DICT) */ { if (interp == NULL) { return; @@ -228,7 +230,11 @@ ConvertError( case Z_MEM_ERROR: codeStr = "MEM"; break; case Z_BUF_ERROR: codeStr = "BUF"; break; case Z_VERSION_ERROR: codeStr = "VERSION"; break; - case Z_NEED_DICT: codeStr = "NEED_DICT"; break; + case Z_NEED_DICT: + codeStr = "NEED_DICT"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%lu", adler); + break; default: codeStr = "unknown"; codeStr2 = codeStrBuf; @@ -640,7 +646,7 @@ Tcl_ZlibStreamInit( } if (e != Z_OK) { - ConvertError(interp, e); + ConvertError(interp, e, zshPtr->stream.adler); goto error; } @@ -886,7 +892,7 @@ Tcl_ZlibStreamReset( } if (e != Z_OK) { - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); /* TODO:cleanup */ return TCL_ERROR; } @@ -1047,7 +1053,7 @@ Tcl_ZlibStreamPut( e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e != Z_OK) { if (zshPtr->interp) { - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); } return TCL_ERROR; } @@ -1093,7 +1099,7 @@ Tcl_ZlibStreamPut( } if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) { if (zshPtr->interp) { - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); } return TCL_ERROR; } @@ -1296,7 +1302,7 @@ Tcl_ZlibStreamGet( } if (!(e==Z_OK || e==Z_STREAM_END || e==Z_BUF_ERROR)) { Tcl_SetByteArrayLength(data, existing); - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); return TCL_ERROR; } if (e == Z_STREAM_END) { @@ -1512,7 +1518,7 @@ Tcl_ZlibDeflate( return TCL_OK; error: - ConvertError(interp, e); + ConvertError(interp, e, stream.adler); TclDecrRefCount(obj); return TCL_ERROR; } @@ -1691,7 +1697,7 @@ Tcl_ZlibInflate( error: TclDecrRefCount(obj); - ConvertError(interp, e); + ConvertError(interp, e, stream.adler); if (nameBuf) { ckfree(nameBuf); } @@ -2629,7 +2635,7 @@ ZlibTransformClose( if (e != Z_OK && e != Z_STREAM_END) { /* TODO: is this the right way to do errors on close? */ if (!TclInThreadExit()) { - ConvertError(interp, e); + ConvertError(interp, e, cd->outStream.adler); } result = TCL_ERROR; break; @@ -2915,7 +2921,7 @@ ZlibTransformSetOption( /* not used */ if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { code = SetDeflateDictionary(&cd->outStream, compDictObj); if (code != Z_OK) { - ConvertError(interp, code); + ConvertError(interp, code, cd->outStream.adler); return TCL_ERROR; } } @@ -2951,7 +2957,7 @@ ZlibTransformSetOption( /* not used */ if (e == Z_BUF_ERROR) { break; } else if (e != Z_OK) { - ConvertError(interp, e); + ConvertError(interp, e, cd->outStream.adler); return TCL_ERROR; } else if (cd->outStream.avail_out == 0) { break; diff --git a/tests/zlib.test b/tests/zlib.test index cc3900d..ba21cd1 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -230,16 +230,19 @@ test zlib-8.8 {transformtion and fconfigure} -setup { set msg "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set dict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" } -constraints zlib -body { - zlib push deflate $outSide -dictionary $dict + zlib push compress $outSide -dictionary $dict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $msg chan pop $outSide - list [string length [zlib deflate $msg]] [string length [read $inSide]] + set compressed [read $inSide] + catch {zlib decompress $compressed} err opt + list [string length [zlib deflate $msg]] [string length $compressed] \ + $err [dict get $opt -errorcode] [zlib adler32 $dict] } -cleanup { catch {close $outSide} catch {close $inSide} -} -result {254 212} +} -result {254 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From b49f1ffb1b107a3fccc849aa2bbd378a2348e6db Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 6 Jun 2012 09:30:31 +0000 Subject: more tests, more failures, more docs --- doc/zlib.n | 35 ++++++++++++++++++++++++---- generic/tclZlib.c | 15 ++++++++++-- tests/zlib.test | 68 +++++++++++++++++++++++++++++++++++++++++++++++-------- 3 files changed, 102 insertions(+), 16 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index 2e08d71..ec3ea5a 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -277,10 +277,10 @@ the transformed data. The full set of subcommands supported by a streaming instance command, \fIstream\fR, is as follows: .TP -\fIstream \fBadd\fR ?\fIoption\fR? \fIdata\fR +\fIstream \fBadd\fR ?\fIoption...\fR? \fIdata\fR . A short-cut for -.QW "\fIstream \fBput \fIoption data\fR" +.QW "\fIstream \fBput \fR?\fIoption...\fR? \fIdata\fR" followed by .QW "\fIstream \fBget\fR" . .TP @@ -325,14 +325,24 @@ Return the gzip header description dictionary extracted from the stream. Only supported for streams created with their \fImode\fR parameter set to \fBgunzip\fR. .TP -\fIstream \fBput\fR ?\fIoption\fR? \fIdata\fR +\fIstream \fBput\fR ?\fIoption...\fR? \fIdata\fR . Append the contents of the binary string \fIdata\fR to \fIstream\fR's internal -buffers while applying the transformation. If present, \fIoption\fR must be -one of the following (or an unambiguous prefix) which are used to modify the +buffers while applying the transformation. The following \fIoption\fRs are +supported (or an unambiguous prefix of them), which are used to modify the way in which the transformation is applied: .RS .TP +\fB\-buffer\fI bufferSize\fR +. +\fITODO: document this\fR +.TP +\fB\-dictionary\fI compressionDictionary\fR +.VS "TIP 400" +Sets a compression dictionary to use when working with compressing or +decompressing the data. +.VE +.TP \fB\-finalize\fR . Mark the stream as finished, ensuring that all bytes have been wholly @@ -340,12 +350,22 @@ compressed or decompressed. For gzip streams, this also ensures that the footer is written to the stream. The stream will need to be reset before having more data written to it after this, though data can still be read out of the stream with the \fBget\fR subcommand. +.RS +.PP +This option is mutually exclusive with the \fB\-flush\fR and \fB\-fullflush\fR +options. +.RE .TP \fB\-flush\fR . Ensure that a decompressor consuming the bytes that the current (compressing) stream is producing will be able to produce all the bytes that have been compressed so far, at some performance penalty. +.RS +.PP +This option is mutually exclusive with the \fB\-finalize\fR and +\fB\-fullflush\fR options. +.RE .TP \fB\-fullflush\fR . @@ -353,6 +373,11 @@ Ensure that not only can a decompressor handle all the bytes produced so far (as with \fB\-flush\fR above) but also that it can restart from this point if it detects that the stream is partially corrupt. This incurs a substantial performance penalty. +.RS +.PP +This option is mutually exclusive with the \fB\-finalize\fR and \fB\-flush\fR +options. +.RE .RE .TP \fIstream \fBreset\fR diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 333c2fa..22ab061 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2350,10 +2350,10 @@ ZlibStreamCmd( zs_fullflush, zs_get, zs_header, zs_put, zs_reset }; static const char *const add_options[] = { - "-buffer", "-finalize", "-flush", "-fullflush", NULL + "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; enum addOptions { - ao_buffer, ao_finalize, ao_flush, ao_fullflush + ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush }; if (objc < 2) { @@ -2415,6 +2415,12 @@ ZlibStreamCmd( NULL); return TCL_ERROR; } + break; + case ao_dictionary: + Tcl_AppendResult(interp, + "\"-dictionary\" option not implemented", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); + return TCL_ERROR; } if (flush == -2) { @@ -2474,6 +2480,11 @@ ZlibStreamCmd( "\"-buffer\" option not supported here", NULL); Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); return TCL_ERROR; + case ao_dictionary: + Tcl_AppendResult(interp, + "\"-dictionary\" option not implemented", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); + return TCL_ERROR; } if (flush == -2) { Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " diff --git a/tests/zlib.test b/tests/zlib.test index ba21cd1..cfde1be 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -223,26 +223,76 @@ test zlib-8.7 {transformation and fconfigure} -setup { catch {close $fd} removeFile $file } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +# Input is headers from fetching SPDY draft +# Dictionary is that which is proposed _in_ SPDY draft +set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" +set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" test zlib-8.8 {transformtion and fconfigure} -setup { lassign [chan pipe] inSide outSide - # Input is headers from fetching SPDY draft - # Dictionary is that which is proposed _in_ SPDY draft - set msg "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" - set dict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" } -constraints zlib -body { - zlib push compress $outSide -dictionary $dict + zlib push compress $outSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary - puts -nonewline $outSide $msg + puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] catch {zlib decompress $compressed} err opt - list [string length [zlib deflate $msg]] [string length $compressed] \ - $err [dict get $opt -errorcode] [zlib adler32 $dict] + list [string length [zlib compress $spdyHeaders]] \ + [string length $compressed] \ + $err [dict get $opt -errorcode] [zlib adler32 $spdyDict] } -cleanup { catch {close $outSide} catch {close $inSide} -} -result {254 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} +} -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} +test zlib-8.9 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream decompress] +} -constraints zlib -body { + zlib push compress $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $outSide + $strm put -dictionary $spdyDict [read $inSide] + list [string length $spdyHeaders] [string length [$strm get]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {260 222} +test zlib-8.10 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push deflate $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $outSide + set compressed [read $inSide] + catch {zlib inflate $compressed} err opt + list [string length [zlib deflate $spdyHeaders]] \ + [string length $compressed] \ + $err [dict get $opt -errorcode] +} -cleanup { + catch {close $outSide} + catch {close $inSide} +} -result {254 212 {data error} {TCL ZLIB DATA}} +test zlib-8.11 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream inflate] +} -constraints zlib -body { + zlib push deflate $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $outSide + $strm put -dictionary $spdyDict [read $inSide] + list [string length $spdyHeaders] [string length [$strm get]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {260 222} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From 4d5127aca4d12e8af41904d360af28fe728defc1 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 6 Jun 2012 10:34:12 +0000 Subject: making the -dictionary option work with streams --- generic/tclZlib.c | 48 ++++++++++++++++++++++++++++++++++++++---------- tests/zlib.test | 4 ++-- 2 files changed, 40 insertions(+), 12 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 22ab061..63d2aca 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2339,7 +2339,7 @@ ZlibStreamCmd( { Tcl_ZlibStream zstream = cd; int command, index, count, code, buffersize = -1, flush = -1, i; - Tcl_Obj *obj; + Tcl_Obj *obj, *compDictObj = NULL; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", "fullflush", "get", "header", "put", "reset", @@ -2404,7 +2404,7 @@ ZlibStreamCmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[i+1], + if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) { return TCL_ERROR; } @@ -2417,10 +2417,15 @@ ZlibStreamCmd( } break; case ao_dictionary: - Tcl_AppendResult(interp, - "\"-dictionary\" option not implemented", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); - return TCL_ERROR; + if (i == objc-2) { + Tcl_AppendResult(interp, "\"-dictionary\" option must be " + "followed by compression dictionary bytes", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; } if (flush == -2) { @@ -2434,6 +2439,15 @@ ZlibStreamCmd( flush = 0; } + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) { return TCL_ERROR; } @@ -2481,10 +2495,15 @@ ZlibStreamCmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); return TCL_ERROR; case ao_dictionary: - Tcl_AppendResult(interp, - "\"-dictionary\" option not implemented", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); - return TCL_ERROR; + if (i == objc-2) { + Tcl_AppendResult(interp, "\"-dictionary\" option must be " + "followed by compression dictionary bytes", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; } if (flush == -2) { Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " @@ -2496,6 +2515,15 @@ ZlibStreamCmd( if (flush == -1) { flush = 0; } + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); case zs_get: /* $strm get ?count? */ diff --git a/tests/zlib.test b/tests/zlib.test index cfde1be..18b6f55 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -259,7 +259,7 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} catch {$strm close} -} -result {260 222} +} -result {358 358} test zlib-8.10 {transformtion and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { @@ -292,7 +292,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} catch {$strm close} -} -result {260 222} +} -result {358 358} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From c0050dd5cd9edb4dc6c44ef057046cf1e2f01a1d Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 7 Jun 2012 07:12:47 +0000 Subject: compressing transforms now work with dictionaries, even if raw --- generic/tclZlib.c | 16 ++++++++++++++++ tests/zlib.test | 16 ++++++++++++++++ 2 files changed, 32 insertions(+) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 585b500..544ba50 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1237,6 +1237,22 @@ Tcl_ZlibStreamGet( } } + /* + * When dealing with a raw stream, we set the dictionary here, once. + * (You can't do it in response to getting Z_NEED_DATA as raw streams + * don't ever issue that.) + */ + + if (zshPtr->format == TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e != Z_OK) { + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + return TCL_ERROR; + } + Tcl_DecrRefCount(zshPtr->compDictObj); + zshPtr->compDictObj = NULL; + } + e = inflate(&zshPtr->stream, zshPtr->flush); if (e == Z_NEED_DICT && zshPtr->compDictObj) { e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); diff --git a/tests/zlib.test b/tests/zlib.test index 18b6f55..5d46926 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -293,6 +293,22 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} +test zlib-8.13 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream compress] +} -constraints {zlib knownBug} -body { + set data [$strm add -dictionary $spdyDict $spdyHeaders] + zlib push decompress $inSide + fconfigure $outSide -blocking 0 -translation binary + fconfigure $inSide -translation binary -dictionary $spdyDict + puts -nonewline $outSide $data + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From f0047f95e154a5f0662db02d4e6df7551c7139de Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 9 Jun 2012 17:52:05 +0000 Subject: tidy up, fix test --- generic/tclZlib.c | 65 ++++++++++++++++++++++++++++++++----------------------- tests/zlib.test | 8 +++---- 2 files changed, 42 insertions(+), 31 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 544ba50..dc9a895 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -87,6 +87,15 @@ typedef struct { * opportunity. */ /* + * Macros to make it clearer in some of the twiddlier accesses what is + * happening. + */ + +#define IsRawStream(zshPtr) ((zshPtr)->format == TCL_ZLIB_FORMAT_RAW) +#define HaveDictToSet(zshPtr) ((zshPtr)->flags & DICT_TO_SET) +#define DictWasSet(zshPtr) ((zshPtr)->flags |= ~DICT_TO_SET) + +/* * Structure used for stacked channel compression and decompression. */ @@ -640,18 +649,12 @@ Tcl_ZlibStreamInit( e = deflateSetHeader(&zshPtr->stream, &zshPtr->gzHeaderPtr->header); } - if (e == Z_OK && zshPtr->compDictObj) { - e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); - } } else { e = inflateInit2(&zshPtr->stream, wbits); if (e == Z_OK && zshPtr->gzHeaderPtr) { e = inflateGetHeader(&zshPtr->stream, &zshPtr->gzHeaderPtr->header); } - if (format==TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj && e==Z_OK) { - e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); - } } if (e != Z_OK) { @@ -889,14 +892,19 @@ Tcl_ZlibStreamReset( if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED, zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); - if (e == Z_OK && zshPtr->compDictObj) { + if (e == Z_OK && HaveDictToSet(zshPtr)) { e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + DictWasSet(zshPtr); + } } } else { e = inflateInit2(&zshPtr->stream, zshPtr->wbits); - if (zshPtr->format == TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj - && e == Z_OK) { + if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr) && e == Z_OK) { e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + DictWasSet(zshPtr); + } } } @@ -1011,6 +1019,10 @@ Tcl_ZlibStreamSetCompressionDictionary( ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; if (compressionDictionaryObj != NULL) { + if (Tcl_IsShared(compressionDictionaryObj)) { + compressionDictionaryObj = + Tcl_DuplicateObj(compressionDictionaryObj); + } Tcl_IncrRefCount(compressionDictionaryObj); zshPtr->flags |= DICT_TO_SET; } else { @@ -1058,7 +1070,7 @@ Tcl_ZlibStreamPut( zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size); zshPtr->stream.avail_in = size; - if (zshPtr->flags & DICT_TO_SET) { + if (HaveDictToSet(zshPtr)) { e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e != Z_OK) { if (zshPtr->interp) { @@ -1066,7 +1078,7 @@ Tcl_ZlibStreamPut( } return TCL_ERROR; } - zshPtr->flags &= ~DICT_TO_SET; + DictWasSet(zshPtr); } /* @@ -1243,20 +1255,21 @@ Tcl_ZlibStreamGet( * don't ever issue that.) */ - if (zshPtr->format == TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj) { + if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) { e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e != Z_OK) { - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + } return TCL_ERROR; } - Tcl_DecrRefCount(zshPtr->compDictObj); - zshPtr->compDictObj = NULL; + DictWasSet(zshPtr); } - e = inflate(&zshPtr->stream, zshPtr->flush); - if (e == Z_NEED_DICT && zshPtr->compDictObj) { + if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) { e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e == Z_OK) { + DictWasSet(zshPtr); e = inflate(&zshPtr->stream, zshPtr->flush); } }; @@ -1313,13 +1326,14 @@ Tcl_ZlibStreamGet( * And call inflate again. */ - e = inflate(&zshPtr->stream, zshPtr->flush); - if (e == Z_NEED_DICT && zshPtr->compDictObj) { - e = SetInflateDictionary(&zshPtr->stream,zshPtr->compDictObj); - if (e == Z_OK) { - e = inflate(&zshPtr->stream, zshPtr->flush); + do { + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e != Z_NEED_DICT || !HaveDictToSet(zshPtr)) { + break; } - } + e = SetInflateDictionary(&zshPtr->stream,zshPtr->compDictObj); + DictWasSet(zshPtr); + } while (e == Z_OK); } if (zshPtr->stream.avail_out > 0) { Tcl_SetByteArrayLength(data, @@ -2158,10 +2172,7 @@ ZlibStreamSubcmd( return TCL_ERROR; } if (compDictObj != NULL) { - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zh; - - zshPtr->compDictObj = compDictObj; - Tcl_IncrRefCount(compDictObj); + Tcl_ZlibStreamSetCompressionDictionary(zh, compDictObj); } Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); return TCL_OK; diff --git a/tests/zlib.test b/tests/zlib.test index 5d46926..9058817 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -293,15 +293,15 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformtion and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] -} -constraints {zlib knownBug} -body { - set data [$strm add -dictionary $spdyDict $spdyHeaders] +} -constraints zlib -body { + $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide fconfigure $outSide -blocking 0 -translation binary fconfigure $inSide -translation binary -dictionary $spdyDict - puts -nonewline $outSide $data + puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] } -cleanup { -- cgit v0.12 From 1434262700eb806dd38e657af9238105a71d174c Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 9 Jun 2012 23:15:51 +0000 Subject: more cross-testing of dictionary-powered compression; describe package configuration --- generic/tclZlib.c | 222 +++++++++++++++++++++++++++++++++++++++++++----------- tests/zlib.test | 58 +++++++++++++- 2 files changed, 235 insertions(+), 45 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index dc9a895..5c90c01 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -166,6 +166,7 @@ static Tcl_ObjCmdProc ZlibStreamCmd; static void ConvertError(Tcl_Interp *interp, int code, uLong adler); +static Tcl_Obj * ConvertErrorToList(int code, uLong adler); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); @@ -232,41 +233,130 @@ ConvertError( int code, /* The zlib error code. */ uLong adler) /* The checksum expected (for Z_NEED_DICT) */ { + const char *codeStr, *codeStr2 = NULL; + char codeStrBuf[TCL_INTEGER_SPACE]; + if (interp == NULL) { return; } - if (code == Z_ERRNO) { + switch (code) { + /* + * Firstly, the case that is *different* because it's really coming + * from the OS and is just being reported via zlib. It should be + * really uncommon because Tcl handles all I/O rather than delegating + * it to zlib, but proving it can't happen is hard. + */ + + case Z_ERRNO: Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp),-1)); - } else { - const char *codeStr, *codeStr2 = NULL; - char codeStrBuf[TCL_INTEGER_SPACE]; - - switch (code) { - case Z_STREAM_ERROR: codeStr = "STREAM"; break; - case Z_DATA_ERROR: codeStr = "DATA"; break; - case Z_MEM_ERROR: codeStr = "MEM"; break; - case Z_BUF_ERROR: codeStr = "BUF"; break; - case Z_VERSION_ERROR: codeStr = "VERSION"; break; - case Z_NEED_DICT: - codeStr = "NEED_DICT"; - codeStr2 = codeStrBuf; - sprintf(codeStrBuf, "%lu", adler); - break; - default: - codeStr = "unknown"; - codeStr2 = codeStrBuf; - sprintf(codeStrBuf, "%d", code); - break; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1)); + return; + + /* + * Normal errors/conditions, some of which have additional detail and + * some which don't. (This is not defined by array lookup because zlib + * error codes are sometimes negative.) + */ + + case Z_STREAM_ERROR: + codeStr = "STREAM"; + break; + case Z_DATA_ERROR: + codeStr = "DATA"; + break; + case Z_MEM_ERROR: + codeStr = "MEM"; + break; + case Z_BUF_ERROR: + codeStr = "BUF"; + break; + case Z_VERSION_ERROR: + codeStr = "VERSION"; + break; + case Z_NEED_DICT: + codeStr = "NEED_DICT"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%lu", adler); + break; + default: + codeStr = "unknown"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%d", code); + break; + + /* + * Finally, these should _not_ happen! This function is for dealing + * with error cases, not non-errors! + */ + + case Z_OK: + Tcl_Panic("unexpected zlib result in error handler: Z_OK"); + case Z_STREAM_END: + Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1)); + + /* + * Tricky point! We might pass NULL twice here (and will when the error + * type is known). + */ + + Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL); +} + +static Tcl_Obj * +ConvertErrorToList( + int code, /* The zlib error code. */ + uLong adler) /* The checksum expected (for Z_NEED_DICT) */ +{ + Tcl_Obj *objv[4]; + + TclNewLiteralStringObj(objv[0], "TCL"); + TclNewLiteralStringObj(objv[1], "ZLIB"); + switch (code) { + case Z_STREAM_ERROR: + TclNewLiteralStringObj(objv[2], "STREAM"); + return Tcl_NewListObj(3, objv); + case Z_DATA_ERROR: + TclNewLiteralStringObj(objv[2], "DATA"); + return Tcl_NewListObj(3, objv); + case Z_MEM_ERROR: + TclNewLiteralStringObj(objv[2], "MEM"); + return Tcl_NewListObj(3, objv); + case Z_BUF_ERROR: + TclNewLiteralStringObj(objv[2], "BUF"); + return Tcl_NewListObj(3, objv); + case Z_VERSION_ERROR: + TclNewLiteralStringObj(objv[2], "VERSION"); + return Tcl_NewListObj(3, objv); + case Z_ERRNO: + TclNewLiteralStringObj(objv[2], "POSIX"); + objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + return Tcl_NewListObj(4, objv); + case Z_NEED_DICT: + TclNewLiteralStringObj(objv[2], "NEED_DICT"); + objv[3] = Tcl_NewWideIntObj((Tcl_WideInt) adler); + return Tcl_NewListObj(4, objv); + + /* + * These should _not_ happen! This function is for dealing with error + * cases, not non-errors! + */ + + case Z_OK: + Tcl_Panic("unexpected zlib result in error handler: Z_OK"); + case Z_STREAM_END: + Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); /* - * Tricky point! We might pass NULL twice here (and will when the - * error type is known). + * Catch-all. Should be unreachable because all cases are already + * listed above. */ - Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL); + default: + TclNewLiteralStringObj(objv[2], "unknown"); + TclNewIntObj(objv[3], code); + return Tcl_NewListObj(4, objv); } } @@ -1832,7 +1922,7 @@ ZlibCmd( } data = Tcl_GetByteArrayFromObj(objv[2], &dlen); Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - Tcl_ZlibAdler32(start, data, dlen))); + (uLong) Tcl_ZlibAdler32(start, data, dlen))); return TCL_OK; case CMD_CRC: /* crc32 str ?startvalue? * -> checksum */ @@ -1849,7 +1939,7 @@ ZlibCmd( } data = Tcl_GetByteArrayFromObj(objv[2], &dlen); Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - Tcl_ZlibCRC32(start, data, dlen))); + (uLong) Tcl_ZlibCRC32(start, data, dlen))); return TCL_OK; case CMD_DEFLATE: /* deflate data ?level? * -> rawCompressedData */ @@ -2637,7 +2727,7 @@ ZlibStreamCmd( return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - Tcl_ZlibStreamChecksum(zstream))); + (uLong) Tcl_ZlibStreamChecksum(zstream))); return TCL_OK; case zs_reset: /* $strm reset */ if (objc != 2) { @@ -2924,6 +3014,7 @@ ZlibTransformOutput( Tcl_DriverOutputProc *outProc = Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent)); int e, produced; + Tcl_Obj *errObj; if (cd->mode == TCL_ZLIB_STREAM_INFLATE) { return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite, @@ -2947,14 +3038,19 @@ ZlibTransformOutput( } } while (e == Z_OK && produced > 0 && cd->outStream.avail_in > 0); - if (e != Z_OK) { - Tcl_SetChannelError(cd->parent, - Tcl_NewStringObj(cd->outStream.msg, -1)); - *errorCodePtr = EINVAL; - return -1; + if (e == Z_OK) { + return toWrite - cd->outStream.avail_in; } - return toWrite - cd->outStream.avail_in; + errObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); + Tcl_ListObjAppendElement(NULL, errObj, + ConvertErrorToList(e, cd->outStream.adler)); + Tcl_ListObjAppendElement(NULL, errObj, + Tcl_NewStringObj(cd->outStream.msg, -1)); + Tcl_SetChannelError(cd->parent, errObj); + *errorCodePtr = EINVAL; + return -1; } /* @@ -2993,12 +3089,19 @@ ZlibTransformSetOption( /* not used */ TclDecrRefCount(cd->compDictObj); } cd->compDictObj = compDictObj; + code = Z_OK; if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { code = SetDeflateDictionary(&cd->outStream, compDictObj); if (code != Z_OK) { ConvertError(interp, code, cd->outStream.adler); return TCL_ERROR; } + } else if (cd->format == TCL_ZLIB_FORMAT_RAW) { + code = SetInflateDictionary(&cd->inStream, compDictObj); + if (code != Z_OK) { + ConvertError(interp, code, cd->inStream.adler); + return TCL_ERROR; + } } return TCL_OK; } @@ -3391,6 +3494,14 @@ ZlibStackChannelTransform( goto error; } } + if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) { + e = SetInflateDictionary(&cd->inStream, cd->compDictObj); + if (e != Z_OK) { + goto error; + } + TclDecrRefCount(cd->compDictObj); + cd->compDictObj = NULL; + } } else { e = deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); @@ -3525,7 +3636,8 @@ ResultGenerate( { #define MAXBUF 1024 unsigned char buf[MAXBUF]; - int e, written; + int e, written,total=0; + Tcl_Obj *errObj; cd->inStream.next_in = (Bytef *) cd->inBuffer; cd->inStream.avail_in = n; @@ -3578,13 +3690,7 @@ ResultGenerate( */ if ((e != Z_OK) && (e != Z_BUF_ERROR)) { - Tcl_Obj *errObj = Tcl_NewListObj(0, NULL); - - Tcl_ListObjAppendElement(NULL, errObj, - Tcl_NewStringObj(cd->inStream.msg, -1)); - Tcl_SetChannelError(cd->parent, errObj); - *errorCodePtr = EINVAL; - return TCL_ERROR; + goto handleError; } /* @@ -3595,6 +3701,17 @@ ResultGenerate( return TCL_OK; } } + + handleError: + errObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); + Tcl_ListObjAppendElement(NULL, errObj, + ConvertErrorToList(e, cd->inStream.adler)); + Tcl_ListObjAppendElement(NULL, errObj, + Tcl_NewStringObj(cd->inStream.msg, -1)); + Tcl_SetChannelError(cd->parent, errObj); + *errorCodePtr = EINVAL; + return TCL_ERROR; } /* @@ -3607,6 +3724,8 @@ int TclZlibInit( Tcl_Interp *interp) { + Tcl_Config cfg[2]; + /* * This does two things. It creates a counter used in the creation of * stream commands, and it creates the namespace that will contain those @@ -3620,6 +3739,23 @@ TclZlibInit( */ Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0); + + /* + * Store the underlying configuration information. + * + * TODO: Describe whether we're using the system version of the library or + * a compatibility version built into Tcl? + */ + + cfg[0].key = "zlibVersion"; + cfg[0].value = zlibVersion(); + cfg[1].key = NULL; + Tcl_RegisterConfig(interp, "zlib", cfg, "ascii"); + + /* + * Formally provide the package as a Tcl built-in. + */ + return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); } diff --git a/tests/zlib.test b/tests/zlib.test index 9058817..e63bd84 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -23,6 +23,9 @@ test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body { test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body { zlib ? {} } -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream} +test zlib-1.3 {zlib basics} -constraints zlib -body { + zlib::pkgconfig list +} -result zlibVersion test zlib-2.1 {zlib compress/decompress} zlib { zlib decompress [zlib compress abcdefghijklm] @@ -252,14 +255,15 @@ test zlib-8.9 {transformtion and fconfigure} -setup { fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders + set result [fconfigure $outSide -checksum] chan pop $outSide $strm put -dictionary $spdyDict [read $inSide] - list [string length $spdyHeaders] [string length [$strm get]] + lappend result [string length $spdyHeaders] [string length [$strm get]] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} -} -result {358 358} +} -result {3064818174 358 358} test zlib-8.10 {transformtion and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { @@ -303,6 +307,56 @@ test zlib-8.12 {transformtion and fconfigure} -setup { fconfigure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] \ + [fconfigure $inSide -checksum] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358 3064818174} +test zlib-8.13 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream compress] +} -constraints zlib -body { + $strm put -dictionary $spdyDict -finalize $spdyHeaders + zlib push decompress $inSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary + fconfigure $inSide -translation binary + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] \ + [fconfigure $inSide -checksum] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358 3064818174} +test zlib-8.14 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream deflate] +} -constraints zlib -body { + $strm put -finalize -dictionary $spdyDict $spdyHeaders + zlib push inflate $inSide + fconfigure $outSide -blocking 0 -buffering none -translation binary + fconfigure $inSide -translation binary -dictionary $spdyDict + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358} +test zlib-8.15 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream deflate] +} -constraints zlib -body { + $strm put -finalize -dictionary $spdyDict $spdyHeaders + zlib push inflate $inSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -buffering none -translation binary + fconfigure $inSide -translation binary + puts -nonewline $outSide [$strm get] + close $outSide list [string length $spdyHeaders] [string length [read $inSide]] } -cleanup { catch {close $outSide} -- cgit v0.12 From e8273026f8af1f2916480057cd1902e0213ce986 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 11 Jun 2012 00:07:52 +0000 Subject: verify zlib package presence and version --- tests/zlib.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/zlib.test b/tests/zlib.test index e63bd84..5f1e5fc 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -26,6 +26,9 @@ test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body { test zlib-1.3 {zlib basics} -constraints zlib -body { zlib::pkgconfig list } -result zlibVersion +test zlib-1.4 {zlib basics} -constraints zlib -body { + package present zlib +} -result 2.0 test zlib-2.1 {zlib compress/decompress} zlib { zlib decompress [zlib compress abcdefghijklm] -- cgit v0.12 From 8a40056c10858ef949de6461513d8b370cb86ea7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 11 Jun 2012 09:34:02 +0000 Subject: new attempt, with only those parts of frq-3527238 which don't introduce new command options, so don't require a TIP --- win/tclWinDde.c | 45 ++++++++++++++++++++++++--------------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/win/tclWinDde.c b/win/tclWinDde.c index e40e114..1e485f9 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1432,15 +1432,15 @@ DdeObjCmd( case DDE_EXECUTE: { int dataLength; - const char *dataString; + const Tcl_UniChar *dataString; if (flags & DDE_FLAG_BINARY) { - dataString = (const char *) + dataString = (const Tcl_UniChar *) Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); } else { dataString = - Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength); - dataLength += 1; + Tcl_GetUnicodeFromObj(objv[firstArg + 2], &dataLength); + dataLength = (dataLength + 1) * sizeof(Tcl_UniChar); } if (dataLength <= 0) { @@ -1461,15 +1461,15 @@ DdeObjCmd( } ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString, - (DWORD) dataLength, 0, 0, CF_TEXT, 0); + (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0); if (ddeData != NULL) { if (flags & DDE_FLAG_ASYNC) { DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, - hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL); + hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeReturn == 0) { SetDdeError(interp); result = TCL_ERROR; @@ -1506,22 +1506,23 @@ DdeObjCmd( CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, - CF_TEXT, XTYP_REQUEST, 5000, NULL); + (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { DWORD tmp; - const char *dataString = (const char *) DdeAccessData(ddeData, &tmp); + const Tcl_UniChar *dataString = (const Tcl_UniChar *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); } else { - if (tmp && !dataString[tmp-1]) { + tmp >>= 1; + if (tmp && !dataString[(tmp-1)]) { --tmp; } - returnObjPtr = Tcl_NewStringObj(dataString, + returnObjPtr = Tcl_NewUnicodeObj(dataString, (int) tmp); } DdeUnaccessData(ddeData); @@ -1569,7 +1570,7 @@ DdeObjCmd( CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(dataString, (DWORD) length, - hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL); + hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; @@ -1712,24 +1713,24 @@ DdeObjCmd( } objPtr = Tcl_ConcatObj(objc, objv); - string = Tcl_GetStringFromObj(objPtr, &length); + string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length); ddeItemData = DdeCreateDataHandle(ddeInstance, - (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0); + (BYTE *) string, (DWORD) 2*length+2, 0, 0, CF_UNICODETEXT, 0); if (flags & DDE_FLAG_ASYNC) { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, 30000, NULL); + CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { ddeCookie = DdeCreateStringHandle(ddeInstance, TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, - CF_TEXT, XTYP_REQUEST, 30000, NULL); + CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); } } @@ -1743,6 +1744,7 @@ DdeObjCmd( if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; + Tcl_UniChar *ddeDataString; /* * The return handle has a two or four element list in it. The @@ -1755,10 +1757,11 @@ DdeObjCmd( resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); - Tcl_SetObjLength(resultPtr, (length + 1) * sizeof(TCHAR) - 1); - string = Tcl_GetString(resultPtr); - DdeGetData(ddeData, (BYTE *) string, (DWORD) length, 0); - Tcl_SetObjLength(resultPtr, (int) strlen(string)); + ddeDataString = ckalloc(length); + DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); + length = (length >> 1) - 1; + resultPtr = Tcl_NewUnicodeObj(ddeDataString, length); + ckfree(ddeDataString); if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); -- cgit v0.12 From d6600f4d5a372ed5c082463d2b0fe958031692d9 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Jun 2012 07:51:38 +0000 Subject: Start to split apart the stream command implementation for easier maintenance. --- generic/tclZlib.c | 418 +++++++++++++++++++++++++++++++----------------------- 1 file changed, 238 insertions(+), 180 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 5c90c01..a7c4453 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -163,6 +163,9 @@ static Tcl_DriverSetOptionProc ZlibTransformSetOption; static Tcl_DriverWatchProc ZlibTransformWatch; static Tcl_ObjCmdProc ZlibCmd; static Tcl_ObjCmdProc ZlibStreamCmd; +static Tcl_ObjCmdProc ZlibStreamAddCmd; +static Tcl_ObjCmdProc ZlibStreamHeaderCmd; +static Tcl_ObjCmdProc ZlibStreamPutCmd; static void ConvertError(Tcl_Interp *interp, int code, uLong adler); @@ -2464,8 +2467,8 @@ ZlibStreamCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = cd; - int command, index, count, code, buffersize = -1, flush = -1, i; - Tcl_Obj *obj, *compDictObj = NULL; + int command, count, code; + Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", "fullflush", "get", "header", "put", "reset", @@ -2475,12 +2478,6 @@ ZlibStreamCmd( zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, zs_fullflush, zs_get, zs_header, zs_put, zs_reset }; - static const char *const add_options[] = { - "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL - }; - enum addOptions { - ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush - }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option data ?...?"); @@ -2494,163 +2491,11 @@ ZlibStreamCmd( switch ((enum zlibStreamCommands) command) { case zs_add: /* $strm add ?$flushopt? $data */ - for (i=2; i -1) { - flush = -2; - } else { - flush = Z_SYNC_FLUSH; - } - break; - case ao_fullflush: /* -fullflush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FULL_FLUSH; - } - break; - case ao_finalize: /* -finalize */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FINISH; - } - break; - case ao_buffer: /* -buffer */ - if (i == objc-2) { - Tcl_AppendResult(interp, "\"-buffer\" option must be " - "followed by integer decompression buffersize", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[++i], - &buffersize) != TCL_OK) { - return TCL_ERROR; - } - if (buffersize < 1 || buffersize > 65536) { - Tcl_AppendResult(interp, - "buffer size must be 32 to 65536", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", - NULL); - return TCL_ERROR; - } - break; - case ao_dictionary: - if (i == objc-2) { - Tcl_AppendResult(interp, "\"-dictionary\" option must be " - "followed by compression dictionary bytes", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - compDictObj = objv[++i]; - break; - } - - if (flush == -2) { - Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " - "\"-finalize\" options are mutually exclusive", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); - return TCL_ERROR; - } - } - if (flush == -1) { - flush = 0; - } - - if (compDictObj != NULL) { - int len; - - (void) Tcl_GetByteArrayFromObj(compDictObj, &len); - if (len == 0) { - compDictObj = NULL; - } - Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); - } - if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) { - return TCL_ERROR; - } - TclNewObj(obj); - code = Tcl_ZlibStreamGet(zstream, obj, buffersize); - if (code == TCL_OK) { - Tcl_SetObjResult(interp, obj); - } else { - TclDecrRefCount(obj); - } - return code; - + return ZlibStreamAddCmd(zstream, interp, objc, objv); + case zs_header: /* $strm header */ + return ZlibStreamHeaderCmd(zstream, interp, objc, objv); case zs_put: /* $strm put ?$flushopt? $data */ - for (i=2; i -1) { - flush = -2; - } else { - flush = Z_SYNC_FLUSH; - } - break; - case ao_fullflush: /* -fullflush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FULL_FLUSH; - } - break; - case ao_finalize: /* -finalize */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FINISH; - } - break; - case ao_buffer: - Tcl_AppendResult(interp, - "\"-buffer\" option not supported here", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); - return TCL_ERROR; - case ao_dictionary: - if (i == objc-2) { - Tcl_AppendResult(interp, "\"-dictionary\" option must be " - "followed by compression dictionary bytes", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - compDictObj = objv[++i]; - break; - } - if (flush == -2) { - Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " - "\"-finalize\" options are mutually exclusive", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); - return TCL_ERROR; - } - } - if (flush == -1) { - flush = 0; - } - if (compDictObj != NULL) { - int len; - - (void) Tcl_GetByteArrayFromObj(compDictObj, &len); - if (len == 0) { - compDictObj = NULL; - } - Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); - } - return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); + return ZlibStreamPutCmd(zstream, interp, objc, objv); case zs_get: /* $strm get ?count? */ if (objc > 3) { @@ -2735,29 +2580,242 @@ ZlibStreamCmd( return TCL_ERROR; } return Tcl_ZlibStreamReset(zstream); - case zs_header: { /* $strm header */ - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zstream; - Tcl_Obj *resultObj; + } - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_OK; +} + +static int +ZlibStreamAddCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_ZlibStream zstream = cd; + int index, code, buffersize = -1, flush = -1, i; + Tcl_Obj *obj, *compDictObj = NULL; + static const char *const add_options[] = { + "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL + }; + enum addOptions { + ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush + }; + + for (i=2; imode != TCL_ZLIB_STREAM_INFLATE - || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) { - Tcl_AppendResult(interp, - "only gunzip streams can produce header information", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL); + } + + switch ((enum addOptions) index) { + case ao_flush: /* -flush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_SYNC_FLUSH; + } + break; + case ao_fullflush: /* -fullflush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FULL_FLUSH; + } + break; + case ao_finalize: /* -finalize */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FINISH; + } + break; + case ao_buffer: /* -buffer */ + if (i == objc-2) { + Tcl_AppendResult(interp, "\"-buffer\" option must be " + "followed by integer decompression buffersize", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) { + return TCL_ERROR; + } + if (buffersize < 1 || buffersize > 65536) { + Tcl_AppendResult(interp, "buffer size must be 32 to 65536", + NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + return TCL_ERROR; + } + break; + case ao_dictionary: + if (i == objc-2) { + Tcl_AppendResult(interp, "\"-dictionary\" option must be " + "followed by compression dictionary bytes", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; + } + + if (flush == -2) { + Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " + "\"-finalize\" options are mutually exclusive", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); return TCL_ERROR; } + } + if (flush == -1) { + flush = 0; + } - TclNewObj(resultObj); - ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; + /* + * Set the compression dictionary if requested. + */ + + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } + + /* + * Send the data to the stream core, along with any flushing directive. + */ + + if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Get such data out as we can (up to the requested length). + */ + + TclNewObj(obj); + code = Tcl_ZlibStreamGet(zstream, obj, buffersize); + if (code == TCL_OK) { + Tcl_SetObjResult(interp, obj); + } else { + TclDecrRefCount(obj); } + return code; +} + +static int +ZlibStreamPutCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_ZlibStream zstream = cd; + int index, flush = -1, i; + Tcl_Obj *compDictObj = NULL; + static const char *const put_options[] = { + "-dictionary", "-finalize", "-flush", "-fullflush", NULL + }; + enum putOptions { + po_dictionary, po_finalize, po_flush, po_fullflush + }; + + for (i=2; i -1) { + flush = -2; + } else { + flush = Z_SYNC_FLUSH; + } + break; + case po_fullflush: /* -fullflush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FULL_FLUSH; + } + break; + case po_finalize: /* -finalize */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FINISH; + } + break; + case po_dictionary: + if (i == objc-2) { + Tcl_AppendResult(interp, "\"-dictionary\" option must be " + "followed by compression dictionary bytes", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; + } + if (flush == -2) { + Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " + "\"-finalize\" options are mutually exclusive", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); + return TCL_ERROR; + } + } + if (flush == -1) { + flush = 0; + } + + /* + * Set the compression dictionary if requested. + */ + + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } + + /* + * Send the data to the stream core, along with any flushing directive. + */ + + return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); +} + +static int +ZlibStreamHeaderCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + ZlibStreamHandle *zshPtr = cd; + Tcl_Obj *resultObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE + || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) { + Tcl_AppendResult(interp, + "only gunzip streams can produce header information", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL); + return TCL_ERROR; } + TclNewObj(resultObj); + ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj); + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -3636,7 +3694,7 @@ ResultGenerate( { #define MAXBUF 1024 unsigned char buf[MAXBUF]; - int e, written,total=0; + int e, written; Tcl_Obj *errObj; cd->inStream.next_in = (Bytef *) cd->inBuffer; -- cgit v0.12 From d751107a263c701401c34c4ae93cea1541ac226f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Jun 2012 07:52:24 +0000 Subject: Documenting the stream command options better. --- doc/zlib.n | 39 +++++++++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index ec3ea5a..2edd62f 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -222,39 +222,54 @@ command works, see \fBSTREAMING INSTANCE COMMAND\fR below. The following modes are supported: .RS .TP -\fBzlib stream compress\fR ?\fIlevel\fR? +\fBzlib stream compress\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces zlib-format output, using compression level \fIlevel\fR (if specified) which will be an integer -from 0 to 9. +from 0 to 9, +.VS +and the compression dictionary \fIbindata\fR (if specified). +.VE .TP -\fBzlib stream decompress\fR +\fBzlib stream decompress\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes zlib-format input and produces uncompressed output. +.VS +If \fIbindata\fR is supplied, it is a compression dictionary to use if +required. +.VE .TP -\fBzlib stream deflate\fR ?\fIlevel\fR? +\fBzlib stream deflate\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces raw output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 -to 9. +to 9, +.VS +and the compression dictionary \fIbindata\fR (if specified). Note that +the raw compressed data includes no metadata about what compression +dictionary was used, if any; that is a feature of the zlib-format data. +.VE .TP -\fBzlib stream gunzip\fR +\fBzlib stream gunzip\fR ?\fIlevel\fR? . The stream will be a decompressing stream that takes gzip-format input and produces uncompressed output. .TP -\fBzlib stream gzip\fR ?\fIlevel\fR? +\fBzlib stream gzip\fR ?\fB\-header \fIheader\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces gzip-format output, using compression level \fIlevel\fR (if specified) which will be an integer -from 0 to 9. +from 0 to 9, and the header descriptor dictionary \fIheader\fR (if specified; +for keys see \fBzlib gzip\fR). '\" TODO: Header dictionary! .TP -\fBzlib stream inflate\fR +\fBzlib stream inflate\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes raw compressed input and -produces uncompressed output. +produces uncompressed output. If \fIbindata\fR is supplied, it is a +compression dictionary to use. Note that there are no checks in place +to determine whether the compression dictionary is correct. .RE .SS "CHECKSUMMING SUBCOMMANDS" .TP @@ -333,10 +348,6 @@ supported (or an unambiguous prefix of them), which are used to modify the way in which the transformation is applied: .RS .TP -\fB\-buffer\fI bufferSize\fR -. -\fITODO: document this\fR -.TP \fB\-dictionary\fI compressionDictionary\fR .VS "TIP 400" Sets a compression dictionary to use when working with compressing or -- cgit v0.12 From ee7e6c078d54016b2158016216c7a0bd209bc9fe Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 24 Jun 2012 15:15:36 +0000 Subject: add configurability of readahead limit --- doc/zlib.n | 41 ++++++++++++-------- generic/tclZlib.c | 113 +++++++++++++++++++++++++++++++++++------------------- 2 files changed, 99 insertions(+), 55 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index a78e8e3..0233ba8 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -179,15 +179,24 @@ Passes a description of the gzip header to create, in the same format that . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). -'\".TP -'\"\fB\-limit\fI readaheadLimit\fR -'\". -'\"The maximum number of bytes ahead to read. -'\"\fITODO: not yet implemented!\fR +.TP +\fB\-limit\fI readaheadLimit\fR +. +The maximum number of bytes ahead to read when decompressing. This defaults to +1, which ensures that data is always decompressed correctly, but may be +increased to improve performance. This is more useful when the channel is +non-blocking. .PP Both compressing and decompressing channel transformations add extra -configuration options that may be accessed through \fBchan configure\fR. Each -option is either a read-only or a write-only option. The options are: +configuration options that may be accessed through \fBchan configure\fR. The +options are: +.TP +\fB\-checksum\fI checksum\fR +. +This read-only option gets the current checksum for the uncompressed data that +the compression engine has seen so far. It is valid for both compressing and +decompressing transforms, but not for the raw inflate and deflate formats. The +compression algorithm depends on what format is being produced or consumed. .TP \fB\-flush\fI type\fR . @@ -198,19 +207,19 @@ expensive flush respectively. Flushing degrades the compression ratio, but makes it easier for a decompressor to recover more of the file in the case of data corruption. .TP -\fB\-checksum\fR -. -This read-only option gets the current checksum for the uncompressed data -that the compression engine has seen so far. It is valid for both -compressing and decompressing transforms, but not for the raw inflate -and deflate formats. The compression algorithm depends on what -format is being produced or consumed. -.TP -\fB\-header\fR +\fB\-header\fI dictionary\fR . This read-only option, only valid for decompressing transforms that are processing gzip-format data, returns the dictionary describing the header read off the data stream. +.TP +\fB\-limit\fI readaheadLimit\fR +. +This read-write option is used by decompressing channels to control the +maximum number of bytes ahead to read from the underlying data source. This +defaults to 1, which ensures that data is always decompressed correctly, but +may be increased to improve performance. This is more useful when the channel +is non-blocking. .RE .SS "STREAMING SUBCOMMAND" .TP diff --git a/generic/tclZlib.c b/generic/tclZlib.c index a7c4453..c96594d 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -110,6 +110,8 @@ typedef struct { int format; /* What format of data is going on the wire. * Needed so that the correct [fconfigure] * options can be enabled. */ + int readAheadLimit; /* The maximum number of bytes to read from + * the underlying stream in one go. */ z_stream inStream; /* Structure used by zlib for decompression of * input. */ z_stream outStream; /* Structure used by zlib for compression of @@ -2958,7 +2960,7 @@ ZlibTransformInput( * reading over the border. */ - readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1); + readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit); /* * Three cases here: @@ -3131,8 +3133,10 @@ ZlibTransformSetOption( /* not used */ ZlibChannelData *cd = instanceData; Tcl_DriverSetOptionProc *setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "dictionary flush"; + static const char *compressChanOptions = "dictionary flush"; static const char *gzipChanOptions = "flush"; + static const char *decompressChanOptions = "dictionary limit"; + static const char *gunzipChanOptions = "flush limit"; int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE); if (optionName && (strcmp(optionName, "-dictionary") == 0) @@ -3164,56 +3168,75 @@ ZlibTransformSetOption( /* not used */ return TCL_OK; } - if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) { - int flushType; + if (haveFlushOpt) { + if (optionName && strcmp(optionName, "-flush") == 0) { + int flushType; - if (value[0] == 'f' && strcmp(value, "full") == 0) { - flushType = Z_FULL_FLUSH; - } else if (value[0] == 's' && strcmp(value, "sync") == 0) { - flushType = Z_SYNC_FLUSH; - } else { - Tcl_AppendResult(interp, "unknown -flush type \"", value, - "\": must be full or sync", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL); - return TCL_ERROR; - } + if (value[0] == 'f' && strcmp(value, "full") == 0) { + flushType = Z_FULL_FLUSH; + } else if (value[0] == 's' && strcmp(value, "sync") == 0) { + flushType = Z_SYNC_FLUSH; + } else { + Tcl_AppendResult(interp, "unknown -flush type \"", value, + "\": must be full or sync", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL); + return TCL_ERROR; + } - /* - * Try to actually do the flush now. - */ + /* + * Try to actually do the flush now. + */ - cd->outStream.avail_in = 0; - while (1) { - int e; + cd->outStream.avail_in = 0; + while (1) { + int e; - cd->outStream.next_out = (Bytef *) cd->outBuffer; - cd->outStream.avail_out = cd->outAllocated; + cd->outStream.next_out = (Bytef *) cd->outBuffer; + cd->outStream.avail_out = cd->outAllocated; - e = deflate(&cd->outStream, flushType); - if (e == Z_BUF_ERROR) { - break; - } else if (e != Z_OK) { - ConvertError(interp, e, cd->outStream.adler); - return TCL_ERROR; - } else if (cd->outStream.avail_out == 0) { - break; + e = deflate(&cd->outStream, flushType); + if (e == Z_BUF_ERROR) { + break; + } else if (e != Z_OK) { + ConvertError(interp, e, cd->outStream.adler); + return TCL_ERROR; + } else if (cd->outStream.avail_out == 0) { + break; + } + + if (Tcl_WriteRaw(cd->parent, cd->outBuffer, + cd->outStream.next_out - (Bytef *) cd->outBuffer)<0) { + Tcl_AppendResult(interp, "problem flushing channel: ", + Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } } + return TCL_OK; + } + } else { + if (optionName && strcmp(optionName, "-limit") == 0) { + int newLimit; - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, - cd->outStream.next_out - (Bytef *) cd->outBuffer) < 0) { - Tcl_AppendResult(interp, "problem flushing channel: ", - Tcl_PosixError(interp), NULL); + if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) { + return TCL_ERROR; + } else if (newLimit < 1 || newLimit > 65535) { + Tcl_AppendResult(interp, "-limit must be between 1 and 65535", + NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL); return TCL_ERROR; } } - return TCL_OK; } if (setOptionProc == NULL) { if (cd->format == TCL_ZLIB_FORMAT_GZIP) { - return Tcl_BadChannelOption(interp, optionName, gzipChanOptions); + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? gzipChanOptions : gunzipChanOptions); } else { - return Tcl_BadChannelOption(interp, optionName, chanOptions); + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? compressChanOptions : decompressChanOptions); } } @@ -3246,7 +3269,10 @@ ZlibTransformGetOption( ZlibChannelData *cd = instanceData; Tcl_DriverGetOptionProc *getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "checksum dictionary header"; + static const char *compressChanOptions = "checksum dictionary"; + static const char *gzipChanOptions = "checksum"; + static const char *decompressChanOptions = "checksum dictionary limit"; + static const char *gunzipChanOptions = "checksum header limit"; /* * The "crc" option reports the current CRC (calculated with the Adler32 @@ -3331,7 +3357,15 @@ ZlibTransformGetOption( if (optionName == NULL) { return TCL_OK; } - return Tcl_BadChannelOption(interp, optionName, chanOptions); + if (cd->format == TCL_ZLIB_FORMAT_GZIP) { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? gzipChanOptions : gunzipChanOptions); + } else { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? compressChanOptions : decompressChanOptions); + } } /* @@ -3496,6 +3530,7 @@ ZlibStackChannelTransform( memset(cd, 0, sizeof(ZlibChannelData)); cd->mode = mode; cd->format = format; + cd->readAheadLimit = 1; if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) { if (mode == TCL_ZLIB_STREAM_DEFLATE) { -- cgit v0.12 From 0d4a963517b406df24acb3713a130366b1ce52a1 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 7 Jul 2012 12:34:39 +0000 Subject: Starting work on support code for cookies. This adds a configurable interface for plugging in a cookie manager (not enabled by default). --- library/http/http.tcl | 93 +++++++++++++++++++++++++++++++++++++++++++++++++++ tests/http.test | 6 ++-- 2 files changed, 96 insertions(+), 3 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index b5ce82b..7b80524 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -24,6 +24,7 @@ namespace eval http { -proxyport {} -proxyfilter http::ProxyRequired -urlencoding utf-8 + -cookiejar {} } # We need a useragent string of this style or various servers will refuse to # send us compressed content even when we ask for it. This follows the @@ -86,6 +87,9 @@ namespace eval http { set defaultKeepalive 0 } + # Regular expression used to parse cookies + variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u0100-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]+)(?:\s*;\s*([^\u0000]+))?} + namespace export geturl config reset wait formatQuery register unregister # Useful, but not exported: data size status code } @@ -498,8 +502,12 @@ proc http::geturl {url args} { } return -code error "Illegal characters in URL path" } + if {![regexp {^[^?#]+} $srvurl state(path)]} { + set state(path) / + } } else { set srvurl / + set state(path) / } if {$proto eq ""} { set proto http @@ -719,6 +727,19 @@ proc http::geturl {url args} { seek $state(-querychannel) $start } + if {$http(-cookiejar) ne ""} { + set cookies "" + set separator "" + foreach {key value} [{*}$http(-cookiejar) \ + getCookies $proto $host $port $state(path)] { + append cookies $separator $key = $value + set separator "; " + } + if {$cookies ne ""} { + puts $sock "Cookie: $cookies" + } + } + # Flush the request header and set up the fileevent that will either # push the POST data or read the response. # @@ -955,6 +976,7 @@ proc http::Write {token} { # Read the socket and handle callbacks. proc http::Event {sock token} { + variable http variable $token upvar 0 $token state @@ -1058,6 +1080,11 @@ proc http::Event {sock token} { set state(connection) \ [string trim [string tolower $value]] } + set-cookie { + if {$http(-cookiejar) ne ""} { + ParseCookie $token $value + } + } } lappend state(meta) $key [string trim $value] } @@ -1147,6 +1174,72 @@ proc http::Event {sock token} { } } +proc http::ParseCookie {token value} { + variable http + variable CookieRE + variable $token + upvar 0 $token state + + if {![regexp $CookieRE $value -> name val opts]} { + # Bad cookie! No biscuit! + return + } + + # Convert the options into a list before feeding into the cookie store; + # ugly, but quite easy. + set realopts {persistent 0 hostonly 1} + foreach opt [split [regsub -all {;\s+} [string trimright $opts] {\u0000}] \u0000] { + switch -glob -- $opt { + Expires=* { + set opt [string range $opt 8 end] + if {[catch { + #Sun, 06 Nov 1994 08:49:37 GMT + dict set realopts expires \ + [clock scan $opt -format "%a, %d %b %Y %T %Z"] + dict set realopts persistent 1 + }] && [catch { + #Sunday, 06-Nov-94 08:49:37 GMT + dict set realopts expires \ + [clock scan $opt -format "%A, %d-%b-%y %T %Z"] + dict set realopts persistent 1 + }]} {catch { + #Sun Nov 6 08:49:37 1994 + dict set realopts expires \ + [clock scan $opt -gmt 1 -format "%a %b %d %T %Y"] + dict set realopts persistent 1 + }} + } + Max-Age=* { + # Normalize + set opt [string range $opt 8 end] + if {[string is integer -strict $opt]} { + dict set realopts expires [expr {[clock seconds] + $opt}] + dict set realopts persistent 1 + } + } + Domain=* { + set opt [string range $opt 7 end] + set opt [string trimleft $opt "."] + # TODO - Domain safety check! + if {$opt ne ""} { + dict set realopts domain $opt + } + } + Path=* { + set opt [string range $opt 5 end] + if {![string match /* $opt]} { + set opt $state(path) + } + dict set realopts path $opt + } + Secure - HttpOnly { + dict set realopts [string tolower $opt] 1 + } + } + } + {*}$http(-cookiejar) storeCookie $token $name $val $realopts +} + # http::getTextLine -- # # Get one line with the stream in blocking crlf mode diff --git a/tests/http.test b/tests/http.test index 37d4a05..daddf2c 100644 --- a/tests/http.test +++ b/tests/http.test @@ -79,7 +79,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { test http-1.1 {http::config} { http::config -useragent UserAgent http::config -} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"] +} [list -accept */* -cookiejar {} -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"] test http-1.2 {http::config} { http::config -proxyfilter } http::ProxyRequired @@ -94,10 +94,10 @@ test http-1.4 {http::config} { set x [http::config] http::config {*}$savedconf set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}} +} {-accept */* -cookiejar {} -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}} test http-1.5 {http::config} -returnCodes error -body { http::config -proxyhost {} -junk 8080 -} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent} +} -result {Unknown option -junk, must be: -accept, -cookiejar, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent} test http-1.6 {http::config} -setup { set oldenc [http::config -urlencoding] } -body { -- cgit v0.12 From b9098ee927b24f571428a5bdbd0f73a14c902388 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 8 Jul 2012 11:15:45 +0000 Subject: Make the parsing work with Google. --- library/http/http.tcl | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 7b80524..181c29f 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -88,7 +88,7 @@ namespace eval http { } # Regular expression used to parse cookies - variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u0100-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]+)(?:\s*;\s*([^\u0000]+))?} + variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u0100-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]*)(?:\s*;\s*([^\u0000]+))?} namespace export geturl config reset wait formatQuery register unregister # Useful, but not exported: data size status code @@ -1082,7 +1082,7 @@ proc http::Event {sock token} { } set-cookie { if {$http(-cookiejar) ne ""} { - ParseCookie $token $value + ParseCookie $token [string trim $value] } } } @@ -1180,7 +1180,7 @@ proc http::ParseCookie {token value} { variable $token upvar 0 $token state - if {![regexp $CookieRE $value -> name val opts]} { + if {![regexp $CookieRE $value -> cookiename cookieval opts]} { # Bad cookie! No biscuit! return } @@ -1188,8 +1188,8 @@ proc http::ParseCookie {token value} { # Convert the options into a list before feeding into the cookie store; # ugly, but quite easy. set realopts {persistent 0 hostonly 1} - foreach opt [split [regsub -all {;\s+} [string trimright $opts] {\u0000}] \u0000] { - switch -glob -- $opt { + foreach opt [split [regsub -all {;\s+} $opts \u0000] \u0000] { + switch -glob -nocase -- $opt { Expires=* { set opt [string range $opt 8 end] if {[catch { @@ -1198,6 +1198,12 @@ proc http::ParseCookie {token value} { [clock scan $opt -format "%a, %d %b %Y %T %Z"] dict set realopts persistent 1 }] && [catch { + # Google does this one + #Mon, 01-Jan-1990 00:00:00 GMT + dict set realopts expires \ + [clock scan $opt -format "%a, %d-%b-%Y %T %Z"] + dict set realopts persistent 1 + }] && [catch { #Sunday, 06-Nov-94 08:49:37 GMT dict set realopts expires \ [clock scan $opt -format "%A, %d-%b-%y %T %Z"] @@ -1237,7 +1243,7 @@ proc http::ParseCookie {token value} { } } } - {*}$http(-cookiejar) storeCookie $token $name $val $realopts + {*}$http(-cookiejar) storeCookie $token $cookiename $cookieval $realopts } # http::getTextLine -- -- cgit v0.12 From 06cfc731c6abebb8f7d67a737dffb55561298d8e Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 11 Jul 2012 10:52:49 +0000 Subject: Start of implementation of cookiejar package. Not yet working/finished. --- library/http/cookiejar.tcl | 104 +++++++++++++++++++++++++++++++++++++++++++++ library/http/http.tcl | 10 +++-- 2 files changed, 110 insertions(+), 4 deletions(-) create mode 100644 library/http/cookiejar.tcl diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl new file mode 100644 index 0000000..eb3b67b --- /dev/null +++ b/library/http/cookiejar.tcl @@ -0,0 +1,104 @@ +package require Tcl 8.6 +package require sqlite3 +package provide cookiejar 0.1 + +::oo::class create cookiejar { + variable aid + constructor {{path ""}} { + if {$path eq ""} { + sqlite3 [namespace current]::db :memory: + } else { + sqlite3 [namespace current]::db $path + } + ## FIXME + db eval { + CREATE TABLE IF NOT EXISTS cookies ( + TEXT origin NOT NULL, + TEXT domain, + TEXT key NOT NULL, + TEXT value NOT NULL, + INTEGER expiry NOT NULL) + PRIMARY KEY (origin, key) + } + db eval { + CREATE TEMP TABLE IF NOT EXISTS sessionCookies ( + TEXT origin NOT NULL, + TEXT domain, + TEXT key NOT NULL, + TEXT value NOT NULL) + PRIMARY KEY (origin, key) + } + + set aid [after 60000 [namespace current]::my PurgeCookies] + } + + destructor { + after cancel $aid + db close + } + + method getCookies {proto host port path} { + upvar 1 state state + set result {} + ## TODO: How to handle prefix matches? + db eval { + SELECT key, value FROM cookies WHERE domain = :host + } cookie { + dict set result $key $value + } + db eval { + SELECT key, value FROM sessionCookies WHERE domain = :host + } cookie { + dict set result $key $value + } + db eval { + SELECT key, value FROM cookies WHERE origin = :host + } cookie { + dict set result $key $value + } + db eval { + SELECT key, value FROM sessionCookies WHERE origin = :host + } cookie { + dict set result $key $value + } + return $result + } + + method storeCookie {name val options} { + upvar 1 state state + set now [clock seconds] + dict with options {} + if {!$persistent} { + ### FIXME + db eval { + INSERT OR REPLACE sessionCookies ( + origin, domain, key, value + ) VALUES (:origin, :domain, :key, :value) + } + } elseif {$expires < $now} { + db eval { + DELETE FROM cookies + WHERE domain = :domain AND key = :name + } + db eval { + DELETE FROM sessionCookies + WHERE domain = :domain AND key = :name + } + } else { + ### FIXME + db eval { + INSERT OR REPLACE cookies ( + origin, domain, key, value, expiry + ) VALUES (:origin, :domain, :key, :value, :expiry) + } + } + } + + method PurgeCookies {} { + set aid [after 60000 [namespace current]::my PurgeCookies] + set now [clock seconds] + db eval {DELETE FROM cookies WHERE expiry < :now} + } + + forward Database db +} diff --git a/library/http/http.tcl b/library/http/http.tcl index afc3a0f..4fa39a4 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -673,8 +673,10 @@ proc http::geturl {url args} { puts $sock "$how $srvurl HTTP/$state(-protocol)" puts $sock "Accept: $http(-accept)" array set hdrs $state(-headers) + set state(host) $host if {[info exists hdrs(Host)]} { # Allow Host spoofing. [Bug 928154] + regexp {^[^:]+} $hdrs(Host) state(host) puts $sock "Host: $hdrs(Host)" } elseif {$port == $defport} { # Don't add port in this case, to handle broken servers. [Bug @@ -1191,6 +1193,7 @@ proc http::ParseCookie {token value} { # Convert the options into a list before feeding into the cookie store; # ugly, but quite easy. set realopts {persistent 0 hostonly 1} + dict set realopts origin $state(host) foreach opt [split [regsub -all {;\s+} $opts \u0000] \u0000] { switch -glob -nocase -- $opt { Expires=* { @@ -1227,10 +1230,9 @@ proc http::ParseCookie {token value} { } } Domain=* { - set opt [string range $opt 7 end] - set opt [string trimleft $opt "."] + set opt [string trimleft [string range $opt 7 end] "."] # TODO - Domain safety check! - if {$opt ne ""} { + if {$opt ne "" && ![string match *. $opt]} { dict set realopts domain $opt } } @@ -1246,7 +1248,7 @@ proc http::ParseCookie {token value} { } } } - {*}$http(-cookiejar) storeCookie $token $cookiename $cookieval $realopts + {*}$http(-cookiejar) storeCookie $cookiename $cookieval $realopts } # http::getTextLine -- -- cgit v0.12 From d9e114d7503c849a470e4ffd4514b7bb0f69fcd6 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Jul 2012 17:09:44 +0000 Subject: Release candidate branch for Tcl 8.6b3. --- README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- tools/tcl.wse.in | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 9 files changed, 10 insertions(+), 10 deletions(-) diff --git a/README b/README index 0442a0e..56f7e38 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6b2 source distribution. + This is the Tcl 8.6b3 source distribution. http://tcl.sourceforge.net/ You can get any source release of Tcl from the file distributions link at the above URL. diff --git a/generic/tcl.h b/generic/tcl.h index 729e521..32d8e1e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -58,10 +58,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_BETA_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 3 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6b2" +#define TCL_PATCH_LEVEL "8.6b3" /* *---------------------------------------------------------------------------- diff --git a/library/init.tcl b/library/init.tcl index d8de540..e4b14d2 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -15,7 +15,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6b2 +package require -exact Tcl 8.6b3 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in index 653b1e1..77beb41 100644 --- a/tools/tcl.wse.in +++ b/tools/tcl.wse.in @@ -12,7 +12,7 @@ item: Global Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 - Disk Label=tcl8.6b2 + Disk Label=tcl8.6b3 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 diff --git a/unix/configure b/unix/configure index 2e36ad2..0b8bc82 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL="b2" +TCL_PATCH_LEVEL="b3" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 79a546d..beff4a3 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL="b2" +TCL_PATCH_LEVEL="b3" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index b35e220..0c42aa4 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6b2 +Version: 8.6b3 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index fed0959..04a5e90 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL="b2" +TCL_PATCH_LEVEL="b3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index 2377938..ae91a0a 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL="b2" +TCL_PATCH_LEVEL="b3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From 92740dd9047be0dac46bae7af8bb3e8b3291e27d Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 12 Jul 2012 10:54:48 +0000 Subject: Update TclOO package to 0.7, correct copyright dates. --- generic/tclOO.c | 2 +- generic/tclOO.h | 5 +++-- generic/tclOOBasic.c | 2 +- generic/tclOOCall.c | 2 +- generic/tclOODefineCmds.c | 2 +- generic/tclOOInfo.c | 2 +- generic/tclOOInt.h | 2 +- generic/tclOOMethod.c | 2 +- tests/oo.test | 4 ++-- tests/ooNext2.test | 10 ++++------ unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 12 files changed, 18 insertions(+), 19 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 821befd..47544f2 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -3,7 +3,7 @@ * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOO.h b/generic/tclOO.h index fef2bd0..280481c 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -4,7 +4,7 @@ * This file contains the public API definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2010 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -34,11 +34,12 @@ extern const char *TclOOInitializeStubs( * version in the files: * * tests/oo.test + * tests/ooNext2.test * unix/tclooConfig.sh * win/tclooConfig.sh */ -#define TCLOO_VERSION "0.6.3" +#define TCLOO_VERSION "0.7" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 35ad1eb..fb1ebc2 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,7 +4,7 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 760bd7b..a79e4fa 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -4,7 +4,7 @@ * This file contains the method call chain management code for the * object-system core. * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 69cffb0..b95681c 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index f298320..c27a1cc 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo-related [info] * subcommands. * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2011 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 631961f..ab54964 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -4,7 +4,7 @@ * This file contains the structure definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2011 by Donal K. Fellows + * Copyright (c) 2006-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 877c3db..f735853 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -3,7 +3,7 @@ * * This file contains code to create and manage methods. * - * Copyright (c) 2005-2008 by Donal K. Fellows + * Copyright (c) 2005-2011 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/oo.test b/tests/oo.test index 00663e9..540cdf3 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,12 +2,12 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2011 Donal K. Fellows +# Copyright (c) 2006-2012 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require -exact TclOO 0.6.3 ;# Must match value in generic/tclOO.h +package require -exact TclOO 0.7 ;# Must match value in generic/tclOO.h package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index eeade11..e78e0d0 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -2,16 +2,14 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2008 Donal K. Fellows +# Copyright (c) 2006-2011 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: oo.test,v 1.59 2011/01/18 16:10:48 dkf Exp $ -package require -exact TclOO 0.6.3 ;# Must match value in configure.in -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +package require -exact TclOO 0.7 ;# Must match value in configure.in +package require tcltest 2 +if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 68de106..dce540a 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS=-DUSE_TCLOO_STUBS -TCLOO_VERSION=0.6.3 +TCLOO_VERSION=0.7 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 68de106..dce540a 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS=-DUSE_TCLOO_STUBS -TCLOO_VERSION=0.6.3 +TCLOO_VERSION=0.7 -- cgit v0.12 From 657ded5397a440b328236e0e1e575df180e331dd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 16 Jul 2012 08:36:20 +0000 Subject: make dde 1.4 loadlable when ::tcl::pkgconfig is available --- library/dde/pkgIndex.tcl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index fef4f24..4cf73d0 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,5 +1,5 @@ -if {![package vsatisfies [package provide Tcl] 8.5]} return -if {[info sharedlibextension] ne ".dll"} return +if {([info commands ::tcl::pkgconfig] eq "") + || ([info sharedlibextension] ne ".dll")} return if {[::tcl::pkgconfig get debug]} { package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde] } else { -- cgit v0.12 From 05904e5ffb9ebe71f9bed3b84472139f8d4394c9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 16 Jul 2012 20:31:44 +0000 Subject: [Bug 3496014]: Unecessary memset() in Tcl_SetByteArrayObj() --- generic/tclBinary.c | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 444e7fa..ae8172f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -307,12 +307,8 @@ Tcl_SetByteArrayObj( byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; - if (length) { - if (bytes) { - memcpy(byteArrayPtr->bytes, bytes, (size_t) length); - } else { - memset(byteArrayPtr->bytes, 0, (size_t) length); - } + if (length && bytes) { + memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } objPtr->typePtr = &tclByteArrayType; -- cgit v0.12 From d7b27b173d6263bcc5291dba4e78cd58905b19d4 Mon Sep 17 00:00:00 2001 From: max Date: Thu, 19 Jul 2012 10:54:13 +0000 Subject: [Bug: 3545363]: Use a large enough buffer for accept()ing IPv6 connections. Fix conversion of host and port for passing to the accept proc to be independent of the IP version. --- ChangeLog | 7 +++++++ win/tclWinSock.c | 11 +++++++---- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 427b3e4..b726d9c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2012-07-19 Reinhard Max + + * win/tclWinSock.c (TcpAccept): [Bug: 3545363]: Use a large enough + buffer for accept()ing IPv6 connections. Fix conversion of host + and port for passing to the accept proc to be independent of the + IP version. + 2012-07-17 Jan Nijtmans * win/makefile.vc: [Bug 3544932]: Visual studio compiler check fails diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 97b10a3..5603ef3 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1556,18 +1556,19 @@ TcpAccept( SOCKET newSocket; SocketInfo *newInfoPtr; SocketInfo *infoPtr = fds->infoPtr; - SOCKADDR_IN addr; + address addr; int len; char channelName[16 + TCL_INTEGER_SPACE]; + char host[NI_MAXHOST], port[NI_MAXSERV]; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); /* * Accept the incoming connection request. */ - len = sizeof(SOCKADDR_IN); + len = sizeof(address); - newSocket = accept(fds->fd, (SOCKADDR *) &addr, &len); + newSocket = accept(fds->fd, &(addr.sa), &len); /* * Protect access to sockets (acceptEventCount, readyEvents) in socketList @@ -1644,8 +1645,10 @@ TcpAccept( */ if (infoPtr->acceptProc != NULL) { + getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); infoPtr->acceptProc(infoPtr->acceptProcData, newInfoPtr->channel, - inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); + host, atoi(port)); } } -- cgit v0.12 From db9c41f45c92a3e57a36432431702960a76360d5 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Jul 2012 16:28:50 +0000 Subject: First attempt at a "bad cookie domain" detector, a critical security check. --- library/http/cookiejar.tcl | 182 ++++++++++++++++++++++++++++++++++++--------- 1 file changed, 148 insertions(+), 34 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index eb3b67b..681c923 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -2,7 +2,13 @@ package require Tcl 8.6 package require sqlite3 package provide cookiejar 0.1 -::oo::class create cookiejar { +namespace eval ::http { + # TODO is this the _right_ list of domains to use? + variable CookiejarDomainList \ + http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 +} + +::oo::class create ::http::cookiejar { variable aid constructor {{path ""}} { if {$path eq ""} { @@ -11,25 +17,105 @@ package provide cookiejar 0.1 sqlite3 [namespace current]::db $path } ## FIXME + ## Model from Safari: + # * Creation instant + # * Domain + # * Expiration instant + # * Name + # * Path + # * Value + ## Model from Firefox: + # CREATE TABLE moz_cookies ( + # id INTEGER PRIMARY KEY, + # name TEXT, + # value TEXT, + # host TEXT, + # path TEXT, + # expiry INTEGER, + # lastAccessed INTEGER, + # isSecure INTEGER, + # isHttpOnly INTEGER, + # baseDomain TEXT, + # creationTime INTEGER) + # CREATE INDEX moz_basedomain ON moz_cookies (baseDomain) + # CREATE UNIQUE INDEX moz_uniqueid ON moz_cookies (name, host, path) db eval { CREATE TABLE IF NOT EXISTS cookies ( - TEXT origin NOT NULL, - TEXT domain, - TEXT key NOT NULL, - TEXT value NOT NULL, - INTEGER expiry NOT NULL) - PRIMARY KEY (origin, key) + id INTEGER PRIMARY KEY, + origin TEXT NOT NULL, + path TEXT NOT NULL, + domain TEXT, + key TEXT NOT NULL, + value TEXT NOT NULL, + expiry INTEGER NOT NULL); + CREATE UNIQUE INDEX IF NOT EXISTS cookieUnique + ON cookies (origin, path, key) } db eval { CREATE TEMP TABLE IF NOT EXISTS sessionCookies ( - TEXT origin NOT NULL, - TEXT domain, - TEXT key NOT NULL, - TEXT value NOT NULL) - PRIMARY KEY (origin, key) + origin TEXT NOT NULL, + path TEXT NOT NULL, + domain TEXT, + key TEXT NOT NULL, + value TEXT NOT NULL); + CREATE UNIQUE INDEX IF NOT EXISTS sessionUnique + ON sessionCookies (origin, path, key) } set aid [after 60000 [namespace current]::my PurgeCookies] + + if {$path ne ""} { + db transaction { + if {[catch { + db eval {SELECT * FROM forbidden LIMIT 1} + }]} { + my InitDomainList + } + } + } + } + + method InitDomainList {} { + db eval { + CREATE TABLE IF NOT EXISTS forbidden ( + domain TEXT PRIMARY KEY); + CREATE TABLE IF NOT EXISTS forbiddenSuper ( + domain TEXT PRIMARY KEY); + CREATE TABLE IF NOT EXISTS permitted ( + domain TEXT PRIMARY KEY); + } + set tok [http::geturl $::http::CookiejarDomainList] + try { + if {[http::ncode $tok] == 200} { + foreach line [split [http::data $tok] \n] { + if {[string trim $line] eq ""} continue + if {[string match //* $line]} continue + if {[string match !* $line]} { + set line [string range $line 1 end] + db eval { + INSERT INTO permitted (domain) + VALUES (:line) + } + } else { + if {[string match {\*.*} $line]} { + set line [string range $line 2 end] + db eval { + INSERT INTO forbiddenSuper (domain) + VALUES (:line) + } + } + db eval { + INSERT INTO forbidden (domain) + VALUES (:line) + } + } + } + } else { + http::Log "Warning: failed to fetch list of forbidden cookie domains" + } + } finally { + http::cleanup $tok + } } destructor { @@ -41,6 +127,8 @@ package provide cookiejar 0.1 upvar 1 state state set result {} ## TODO: How to handle prefix matches? +# From kbk +#LENGTH(theColumn) <= LENGTH(:queryStr) AND SUBSTR(theColumn, LENGTH(:queryStr)-LENGTH(theColumn)+1) = :queryStr db eval { SELECT key, value FROM cookies WHERE domain = :host } cookie { @@ -64,32 +152,56 @@ package provide cookiejar 0.1 return $result } + method BadDomain options { + if {![dict exists $options domain]} { + return 0 + } + set domain [dict get $options domain] + db eval { + SELECT domain FROM permitted WHERE domain == :domain + } x {return 0} + db eval { + SELECT domain FROM forbidden WHERE domain == :domain + } x {return 1} + if {![regexp {^[^.]+\.(.+)$} $domain -> super]} {return 1} + db eval { + SELECT domain FROM forbiddenSuper WHERE domain == :domain + } x {return 1} + return 0 + } + method storeCookie {name val options} { upvar 1 state state set now [clock seconds] - dict with options {} - if {!$persistent} { - ### FIXME - db eval { - INSERT OR REPLACE sessionCookies ( - origin, domain, key, value - ) VALUES (:origin, :domain, :key, :value) - } - } elseif {$expires < $now} { - db eval { - DELETE FROM cookies - WHERE domain = :domain AND key = :name + db transaction { + if {[my BadDomain $options]} { + http::Log "Warning: evil cookie detected" + return } - db eval { - DELETE FROM sessionCookies - WHERE domain = :domain AND key = :name - } - } else { - ### FIXME - db eval { - INSERT OR REPLACE cookies ( - origin, domain, key, value, expiry - ) VALUES (:origin, :domain, :key, :value, :expiry) + dict with options {} + if {!$persistent} { + ### FIXME + db eval { + INSERT OR REPLACE sessionCookies ( + origin, domain, key, value) + VALUES (:origin, :domain, :key, :value) + } + } elseif {$expires < $now} { + db eval { + DELETE FROM cookies + WHERE domain = :domain AND key = :name AND path = :path + } + db eval { + DELETE FROM sessionCookies + WHERE domain = :domain AND key = :name AND path = :path + } + } else { + ### FIXME + db eval { + INSERT OR REPLACE cookies ( + origin, domain, key, value, expiry) + VALUES (:origin, :domain, :key, :value, :expiry) + } } } } @@ -98,6 +210,8 @@ package provide cookiejar 0.1 set aid [after 60000 [namespace current]::my PurgeCookies] set now [clock seconds] db eval {DELETE FROM cookies WHERE expiry < :now} + ### TODO: Cap the total number of cookies and session cookies, + ### purging least frequently used } forward Database db -- cgit v0.12 From cff3f68212952ebdfb8e4bb3330f1ee9e9c97950 Mon Sep 17 00:00:00 2001 From: twylite Date: Tue, 24 Jul 2012 13:58:44 +0000 Subject: [Bug: 3545363]: Handle socket with multiple underlying file descriptors where required (TcpCloseProc, SocketProc). Refactor socket/descriptor setup. Fix memory leak in socket close (TcpCloseProc) and related dangling pointers in SocketEventProc. --- win/tclWinSock.c | 307 +++++++++++++++++++++++++++++++++---------------------- 1 file changed, 187 insertions(+), 120 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 5603ef3..c651deb 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -220,7 +220,7 @@ static void SocketExitHandler(ClientData clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); -static void TcpAccept(TcpFdList *fds); +static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForSocketEvent(SocketInfo *infoPtr, int events, int *errorCodePtr); static DWORD WINAPI SocketThread(LPVOID arg); @@ -692,6 +692,9 @@ SocketEventProc( int mask = 0, events; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); TcpFdList *fds; + SOCKET newSocket; + address addr; + int len; if (!(flags & TCL_FILE_EVENTS)) { return 0; @@ -708,13 +711,13 @@ SocketEventProc( break; } } - SetEvent(tsdPtr->socketListLock); /* * Discard events that have gone stale. */ if (!infoPtr) { + SetEvent(tsdPtr->socketListLock); return 1; } @@ -726,11 +729,65 @@ SocketEventProc( if (infoPtr->readyEvents & FD_ACCEPT) { for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { - TcpAccept(fds); + + /* + * Accept the incoming connection request. + */ + len = sizeof(address); + + newSocket = accept(fds->fd, &(addr.sa), &len); + + /* On Tcl server sockets with multiple OS fds we loop over the fds trying + * an accept() on each, so we expect INVALID_SOCKET. There are also other + * network stack conditions that can result in FD_ACCEPT but a subsequent + * failure on accept() by the time we get around to it. + * Access to sockets (acceptEventCount, readyEvents) in socketList + * is still protected by the lock (prevents reintroduction of + * SF Tcl Bug 3056775. + */ + + if (newSocket == INVALID_SOCKET) { + /* int err = WSAGetLastError(); */ + continue; + } + + /* + * It is possible that more than one FD_ACCEPT has been sent, so an extra + * count must be kept. Decrement the count, and reset the readyEvent bit + * if the count is no longer > 0. + */ + infoPtr->acceptEventCount--; + + if (infoPtr->acceptEventCount <= 0) { + infoPtr->readyEvents &= ~(FD_ACCEPT); + } + + SetEvent(tsdPtr->socketListLock); + + /* Caution: TcpAccept() has the side-effect of evaluating the server + * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can + * close the server socket and invalidate infoPtr and fds. + * If TcpAccept() accepts a socket we must return immediately and let + * SocketCheckProc queue additional FD_ACCEPT events. + */ + TcpAccept(fds, newSocket, addr); + return 1; } + + /* Loop terminated with no sockets accepted; clear the ready mask so + * we can detect the next connection request. Note that connection + * requests are level triggered, so if there is a request already + * pending, a new event will be generated. + */ + infoPtr->acceptEventCount = 0; + infoPtr->readyEvents &= ~(FD_ACCEPT); + + SetEvent(tsdPtr->socketListLock); return 1; } + SetEvent(tsdPtr->socketListLock); + /* * Mask off unwanted events and compute the read/write mask so we can * notify the channel. @@ -872,9 +929,15 @@ TcpCloseProc( * background. */ - if (closesocket(infoPtr->sockets->fd) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); + while ( infoPtr->sockets != NULL ) { + TcpFdList *thisfd = infoPtr->sockets; + infoPtr->sockets = thisfd->next; + + if (closesocket(thisfd->fd) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); + } + ckfree(thisfd); } } @@ -934,6 +997,8 @@ TcpClose2Proc( return TCL_ERROR; } + /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or + * TCL_WRITABLE so this should never be called for a server socket. */ if (shutdown(infoPtr->sockets->fd, sd) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); errorCode = Tcl_GetErrno(); @@ -945,6 +1010,51 @@ TcpClose2Proc( /* *---------------------------------------------------------------------- * + * AddSocketInfoFd -- + * + * This function adds a SOCKET file descriptor to the 'sockets' linked + * list of a SocketInfo structure. + * + * Results: + * None. + * + * Side effects: + * None, except for allocation of memory. + * + *---------------------------------------------------------------------- + */ + +static void +AddSocketInfoFd( + SocketInfo *infoPtr, + SOCKET socket) +{ + TcpFdList *fds = infoPtr->sockets; + + if ( fds == NULL ) { + /* Add the first FD */ + infoPtr->sockets = ckalloc(sizeof(TcpFdList)); + fds = infoPtr->sockets; + } else { + /* Find end of list and append FD */ + while ( fds->next != NULL ) { + fds = fds->next; + } + + fds->next = ckalloc(sizeof(TcpFdList)); + fds = fds->next; + } + + /* Populate new FD */ + fds->fd = socket; + fds->infoPtr = infoPtr; + fds->next = NULL; +} + + +/* + *---------------------------------------------------------------------- + * * NewSocketInfo -- * * This function allocates and initializes a new SocketInfo structure. @@ -963,14 +1073,10 @@ NewSocketInfo( SOCKET socket) { SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo)); - TcpFdList *fds = ckalloc(sizeof(TcpFdList)); - fds->fd = socket; - fds->next = NULL; - fds->infoPtr = infoPtr; /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ infoPtr->channel = 0; - infoPtr->sockets = fds; + infoPtr->sockets = NULL; infoPtr->flags = 0; infoPtr->watchEvents = 0; infoPtr->readyEvents = 0; @@ -988,6 +1094,8 @@ NewSocketInfo( infoPtr->nextPtr = NULL; + AddSocketInfoFd(infoPtr, socket); + return infoPtr; } @@ -1057,7 +1165,6 @@ CreateSocket( } if (server) { - TcpFdList *fds = NULL, *newfds; for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { sock = socket(addrPtr->ai_family, SOCK_STREAM, 0); @@ -1140,7 +1247,6 @@ CreateSocket( */ infoPtr = NewSocketInfo(sock); - fds = infoPtr->sockets; /* * Set up the select mask for connection request events. @@ -1150,13 +1256,7 @@ CreateSocket( infoPtr->watchEvents |= FD_ACCEPT; } else { - newfds = ckalloc(sizeof(TcpFdList)); - memset(newfds, (int) 0, sizeof(TcpFdList)); - newfds->fd = sock; - newfds->infoPtr = infoPtr; - newfds->next = NULL; - fds->next = newfds; - fds = newfds; + AddSocketInfoFd( infoPtr, sock ); } } } else { @@ -1537,8 +1637,9 @@ Tcl_OpenTcpServer( * * TcpAccept -- * - * Accept a TCP socket connection. This is called by SocketEventProc and - * it in turns calls the registered accept function. + * Creates a channel for a newly accepted socket connection. This is + * called by SocketEventProc and it in turns calls the registered + * accept function. * * Results: * None. @@ -1551,61 +1652,18 @@ Tcl_OpenTcpServer( static void TcpAccept( - TcpFdList *fds) /* Socket to accept. */ + TcpFdList *fds, /* Server socket that accepted newSocket. */ + SOCKET newSocket, /* Newly accepted socket. */ + address addr) /* Address of new socket. */ { - SOCKET newSocket; SocketInfo *newInfoPtr; SocketInfo *infoPtr = fds->infoPtr; - address addr; - int len; + int len = sizeof(addr); char channelName[16 + TCL_INTEGER_SPACE]; char host[NI_MAXHOST], port[NI_MAXSERV]; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); /* - * Accept the incoming connection request. - */ - - len = sizeof(address); - - newSocket = accept(fds->fd, &(addr.sa), &len); - - /* - * Protect access to sockets (acceptEventCount, readyEvents) in socketList - * by the lock. Fix for SF Tcl Bug 3056775. - */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - - /* - * Clear the ready mask so we can detect the next connection request. Note - * that connection requests are level triggered, so if there is a request - * already pending, a new event will be generated. - */ - - if (newSocket == INVALID_SOCKET) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_ACCEPT); - - SetEvent(tsdPtr->socketListLock); - return; - } - - /* - * It is possible that more than one FD_ACCEPT has been sent, so an extra - * count must be kept. Decrement the count, and reset the readyEvent bit - * if the count is no longer > 0. - */ - - infoPtr->acceptEventCount--; - - if (infoPtr->acceptEventCount <= 0) { - infoPtr->readyEvents &= ~(FD_ACCEPT); - } - - SetEvent(tsdPtr->socketListLock); - - /* * Win-NT has a misfeature that sockets are inherited in child processes * by default. Turn off the inherit bit. */ @@ -1648,7 +1706,7 @@ TcpAccept( getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), NI_NUMERICHOST|NI_NUMERICSERV); infoPtr->acceptProc(infoPtr->acceptProcData, newInfoPtr->channel, - host, atoi(port)); + host, atoi(port)); } } @@ -1723,6 +1781,7 @@ TcpInputProc( while (1) { SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); + /* single fd operation: this proc is only called for a connected socket. */ bytesRead = recv(infoPtr->sockets->fd, buf, toRead, 0); infoPtr->readyEvents &= ~(FD_READ); @@ -1843,6 +1902,7 @@ TcpOutputProc( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); + /* single fd operation: this proc is only called for a connected socket. */ bytesWritten = send(infoPtr->sockets->fd, buf, toWrite, 0); if (bytesWritten != SOCKET_ERROR) { /* @@ -1938,6 +1998,7 @@ TcpSetOptionProc( } #ifdef TCL_FEATURE_KEEPALIVE_NAGLE + #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat infoPtr->sockets as single fd or list" sock = infoPtr->sockets->fd; if (!strcasecmp(optionName, "-keepalive")) { @@ -2401,6 +2462,7 @@ SocketProc( int event, error; SOCKET socket; SocketInfo *infoPtr; + TcpFdList *fds = NULL; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) #ifdef _WIN64 GetWindowLongPtr(hwnd, GWLP_USERDATA); @@ -2445,58 +2507,60 @@ SocketProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->sockets->fd == socket) { - /* - * Update the socket state. - * - * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event - * happens, then clear the FD_ACCEPT count. Otherwise, - * increment the count if the current event is an FD_ACCEPT. - */ - - if (event & FD_CLOSE) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); - } else if (event & FD_ACCEPT) { - infoPtr->acceptEventCount++; - } - - if (event & FD_CONNECT) { + for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { + if (fds->fd == socket) { /* - * The socket is now connected, clear the async connect - * flag. + * Update the socket state. + * + * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event + * happens, then clear the FD_ACCEPT count. Otherwise, + * increment the count if the current event is an FD_ACCEPT. */ - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + if (event & FD_CLOSE) { + infoPtr->acceptEventCount = 0; + infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); + } else if (event & FD_ACCEPT) { + infoPtr->acceptEventCount++; + } - /* - * Remember any error that occurred so we can report - * connection failures. - */ + if (event & FD_CONNECT) { + /* + * The socket is now connected, clear the async connect + * flag. + */ + + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - if (error != ERROR_SUCCESS) { - TclWinConvertError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); + /* + * Remember any error that occurred so we can report + * connection failures. + */ + + if (error != ERROR_SUCCESS) { + TclWinConvertError((DWORD) error); + infoPtr->lastError = Tcl_GetErrno(); + } } - } - if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - if (error != ERROR_SUCCESS) { - TclWinConvertError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); + if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + if (error != ERROR_SUCCESS) { + TclWinConvertError((DWORD) error); + infoPtr->lastError = Tcl_GetErrno(); + } + infoPtr->readyEvents |= FD_WRITE; } - infoPtr->readyEvents |= FD_WRITE; - } - infoPtr->readyEvents |= event; + infoPtr->readyEvents |= event; - /* - * Wake up the Main Thread. - */ + /* + * Wake up the Main Thread. + */ - SetEvent(tsdPtr->readyEvent); - Tcl_ThreadAlert(tsdPtr->threadId); - break; + SetEvent(tsdPtr->readyEvent); + Tcl_ThreadAlert(tsdPtr->threadId); + break; + } } } SetEvent(tsdPtr->socketListLock); @@ -2504,15 +2568,18 @@ SocketProc( case SOCKET_SELECT: infoPtr = (SocketInfo *) lParam; - if (wParam == SELECT) { - WSAAsyncSelect(infoPtr->sockets->fd, hwnd, - SOCKET_MESSAGE, infoPtr->selectEvents); - } else { - /* - * Clear the selection mask - */ + for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { + infoPtr = (SocketInfo *) lParam; + if (wParam == SELECT) { + WSAAsyncSelect(fds->fd, hwnd, + SOCKET_MESSAGE, infoPtr->selectEvents); + } else { + /* + * Clear the selection mask + */ - WSAAsyncSelect(infoPtr->sockets->fd, hwnd, 0, 0); + WSAAsyncSelect(fds->fd, hwnd, 0, 0); + } } break; -- cgit v0.12 From f85f2e89ee3ded53ae45bbd7d39233b785be3aa2 Mon Sep 17 00:00:00 2001 From: twylite Date: Mon, 30 Jul 2012 14:01:35 +0000 Subject: Updated ChangeLog for changes in [7a82c3e6] --- ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ChangeLog b/ChangeLog index b726d9c..2ed0d85 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-07-24 Trevor Davel + + * win/tclWinSock.c: [Bug: 3545363]: Loop over multiple underlying file + descriptors for a socket where required (TcpCloseProc, SocketProc). Refactor + socket/descriptor setup to manage linked list operations in one place. Fix + memory leak in socket close (TcpCloseProc) and related dangling pointers in + SocketEventProc. + 2012-07-19 Reinhard Max * win/tclWinSock.c (TcpAccept): [Bug: 3545363]: Use a large enough -- cgit v0.12 From 99af655c4c86349d99454dd9c6879ec83e32f1f2 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Jul 2012 10:52:29 +0000 Subject: some small tinkerings --- library/http/cookiejar.tcl | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index be446a1..e6c1e85 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -42,9 +42,9 @@ namespace eval ::http { db eval { CREATE TABLE IF NOT EXISTS cookies ( id INTEGER PRIMARY KEY, - origin TEXT NOT NULL, + origin TEXT NOT NULL COLLATE NOCASE, path TEXT NOT NULL, - domain TEXT, + domain TEXT COLLATE NOCASE, key TEXT NOT NULL, value TEXT NOT NULL, expiry INTEGER NOT NULL); @@ -53,9 +53,9 @@ namespace eval ::http { } db eval { CREATE TEMP TABLE IF NOT EXISTS sessionCookies ( - origin TEXT NOT NULL, + origin TEXT NOT NULL COLLATE NOCASE, path TEXT NOT NULL, - domain TEXT, + domain TEXT COLLATE NOCASE, key TEXT NOT NULL, value TEXT NOT NULL); CREATE UNIQUE INDEX IF NOT EXISTS sessionUnique @@ -66,9 +66,11 @@ namespace eval ::http { if {$path ne ""} { db transaction { - if {[catch { - db eval {SELECT * FROM forbidden LIMIT 1} - }]} { + db eval { + SELECT count(*) AS present FROM sqlite_master + WHERE type='table' AND name='forbidden' + } + if {!$present} { my InitDomainList } } -- cgit v0.12 From c525f5049c4f7698eff261177a56da0fea9620c6 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 3 Aug 2012 10:56:28 +0000 Subject: converting to using Tcl_Obj API for error message generation; part done --- generic/tclBasic.c | 129 ++++++++++++------------ generic/tclClock.c | 4 +- generic/tclCmdAH.c | 5 +- generic/tclCmdIL.c | 251 ++++++++++++++++++++++++---------------------- generic/tclConfig.c | 8 +- generic/tclDictObj.c | 39 ++++--- generic/tclEnsemble.c | 167 +++++++++++++++++++----------- generic/tclExecute.c | 38 +++---- generic/tclFileName.c | 39 +++---- generic/tclIORChan.c | 3 +- generic/tclIOUtil.c | 5 +- generic/tclLoad.c | 10 +- generic/tclLoadNone.c | 4 +- generic/tclOO.c | 48 +++++---- generic/tclOOBasic.c | 100 ++++++++++-------- generic/tclOODefineCmds.c | 140 +++++++++++++++----------- generic/tclOOInfo.c | 64 ++++++------ generic/tclOOMethod.c | 8 +- generic/tclOOStubLib.c | 11 +- generic/tclParse.c | 29 +++--- generic/tclPipe.c | 8 +- generic/tclPkg.c | 9 +- generic/tclScan.c | 55 +++++----- generic/tclTrace.c | 19 ++-- generic/tclUtil.c | 40 +++----- generic/tclVar.c | 73 +++++++------- generic/tclZlib.c | 25 ++--- win/tclWinDde.c | 6 +- 28 files changed, 742 insertions(+), 595 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 537750e..db365e3 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1708,9 +1708,9 @@ Tcl_HideCommand( */ if (strstr(hiddenCmdToken, "::") != NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use namespace qualifiers in hidden command" - " token (rename)", NULL); + " token (rename)", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL); return TCL_ERROR; } @@ -1733,8 +1733,9 @@ Tcl_HideCommand( */ if (cmdPtr->nsPtr != iPtr->globalNsPtr) { - Tcl_AppendResult(interp, "can only hide global namespace commands" - " (use rename then hide)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only hide global namespace commands (use rename then hide)", + -1)); Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL); return TCL_ERROR; } @@ -1758,8 +1759,9 @@ Tcl_HideCommand( hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew); if (!isNew) { - Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, - "\" already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "hidden command named \"%s\" already exists", + hiddenCmdToken)); Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL); return TCL_ERROR; } @@ -1861,8 +1863,9 @@ Tcl_ExposeCommand( */ if (strstr(cmdName, "::") != NULL) { - Tcl_AppendResult(interp, "cannot expose to a namespace " - "(use expose to toplevel, then rename)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot expose to a namespace (use expose to toplevel, then rename)", + -1)); Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL); return TCL_ERROR; } @@ -1877,8 +1880,8 @@ Tcl_ExposeCommand( hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); } if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown hidden command \"%s\"", hiddenCmdToken)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", hiddenCmdToken, NULL); return TCL_ERROR; @@ -1897,9 +1900,9 @@ Tcl_ExposeCommand( * than 'nicely' erroring out ? */ - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "trying to expose a non-global command namespace command", - NULL); + -1)); return TCL_ERROR; } @@ -1916,8 +1919,8 @@ Tcl_ExposeCommand( hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); if (!isNew) { - Tcl_AppendResult(interp, "exposed command \"", cmdName, - "\" already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "exposed command \"%s\" already exists", cmdName)); Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL); return TCL_ERROR; } @@ -2497,9 +2500,10 @@ TclRenameCommand( cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "can't ", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't %s \"%s\": command doesn't exist", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", - " \"", oldName, "\": command doesn't exist", NULL); + oldName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } @@ -2529,15 +2533,15 @@ TclRenameCommand( TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); if ((newNsPtr == NULL) || (newTail == NULL)) { - Tcl_AppendResult(interp, "can't rename to \"", newName, - "\": bad command name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't rename to \"%s\": bad command name", newName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); result = TCL_ERROR; goto done; } if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { - Tcl_AppendResult(interp, "can't rename to \"", newName, - "\": command already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't rename to \"%s\": command already exists", newName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", "TARGET_EXISTS", NULL); result = TCL_ERROR; @@ -3538,9 +3542,9 @@ OldMathFuncProc( * We have a non-numeric argument. */ - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", - TCL_STATIC); + -1)); TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); ckfree(args); return TCL_ERROR; @@ -3827,9 +3831,8 @@ TclInterpReady( */ if (iPtr->flags & DELETED) { - /* JJM - Superfluous Tcl_ResetResult call removed. */ - Tcl_AppendResult(interp, - "attempt to call eval in deleted interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to call eval in deleted interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "IDELETE", "attempt to call eval in deleted interpreter", NULL); return TCL_ERROR; @@ -3857,8 +3860,8 @@ TclInterpReady( return TCL_OK; } - Tcl_AppendResult(interp, - "too many nested evaluations (infinite loop?)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "too many nested evaluations (infinite loop?)", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL); return TCL_ERROR; } @@ -3992,8 +3995,7 @@ Tcl_Canceled( } } - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, message, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL); } @@ -4616,8 +4618,8 @@ TEOV_NotFound( cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr); if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[0]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", TclGetString(objv[0]), NULL); @@ -6285,11 +6287,11 @@ ProcessUnexpectedResult( Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { - Tcl_AppendResult(interp, - "invoked \"break\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invoked \"break\" outside of a loop", -1)); } else if (returnCode == TCL_CONTINUE) { - Tcl_AppendResult(interp, - "invoked \"continue\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invoked \"continue\" outside of a loop", -1)); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "command returned bad code: %d", returnCode)); @@ -6624,7 +6626,8 @@ TclObjInvoke( } if ((objc < 1) || (objv == NULL)) { - Tcl_AppendResult(interp, "illegal argument vector", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal argument vector", -1)); return TCL_ERROR; } @@ -6642,8 +6645,8 @@ TclObjInvoke( hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); } if (hPtr == NULL) { - Tcl_AppendResult(interp, "invalid hidden command name \"", - cmdName, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid hidden command name \"%s\"", cmdName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, NULL); return TCL_ERROR; @@ -7269,7 +7272,8 @@ ExprIsqrtFunc( return TCL_OK; negarg: - Tcl_SetResult(interp, "square root of negative argument", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "square root of negative argument", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); return TCL_ERROR; @@ -8319,9 +8323,8 @@ TclNRTailcallObjCmd( } if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */ - Tcl_SetResult(interp, - "tailcall can only be called from a proc or lambda", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc or lambda", -1)); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); return TCL_ERROR; } @@ -8480,8 +8483,8 @@ TclNRYieldObjCmd( } if (!corPtr) { - Tcl_SetResult(interp, "yield can only be called in a coroutine", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yield can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } @@ -8514,8 +8517,8 @@ TclNRYieldToObjCmd( } if (!corPtr) { - Tcl_SetResult(interp, "yieldto can only be called in a coroutine", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } @@ -8763,8 +8766,8 @@ NRCoroutineActivateCallback( */ if (corPtr->stackLevel != stackLevel) { - Tcl_SetResult(interp, "cannot yield: C stack busy", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot yield: C stack busy", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", NULL); return TCL_ERROR; @@ -8823,8 +8826,8 @@ NRCoroInjectObjCmd( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_AppendResult(interp, "can only inject a command into a coroutine", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", TclGetString(objv[1]), NULL); return TCL_ERROR; @@ -8832,8 +8835,8 @@ NRCoroInjectObjCmd( corPtr = cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_AppendResult(interp, - "can only inject a command into a suspended coroutine", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a suspended coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); return TCL_ERROR; } @@ -8860,9 +8863,9 @@ TclNRInterpCoroutine( CoroutineData *corPtr = clientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]), - "\" is already running", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "coroutine \"%s\" is already running", + Tcl_GetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); return TCL_ERROR; } @@ -8943,22 +8946,24 @@ TclNRCoroutineObjCmd( &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": unknown namespace", + fullName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": bad procedure name", + fullName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { - Tcl_AppendResult(interp, "can't create procedure \"", procName, - "\" in non-global namespace with name starting with \":\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\" in non-global namespace with" + " name starting with \":\"", procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 7fa4017..e46ac69 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -878,8 +878,8 @@ ConvertLocalToUTCUsingC( if (localErrno != 0 || (fields->seconds == -1 && timeVal.tm_yday == -1)) { - Tcl_SetResult(interp, "time value too large/small to represent", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "time value too large/small to represent", -1)); return TCL_ERROR; } return TCL_OK; diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f09ee70..4bb993e 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1842,7 +1842,7 @@ PathFilesystemCmd( } fsInfo = Tcl_FSFileSystemInfo(objv[1]); if (fsInfo == NULL) { - Tcl_SetResult(interp, "unrecognised path", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", Tcl_GetString(objv[1]), NULL); return TCL_ERROR; @@ -2092,7 +2092,8 @@ FilesystemSeparatorCmd( Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]); if (separatorObj == NULL) { - Tcl_SetResult(interp, "unrecognised path", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", Tcl_GetString(objv[1]), NULL); return TCL_ERROR; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b312026..14e0092 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -27,15 +27,15 @@ */ typedef struct SortElement { - union { /* The value that we sorting by. */ + union { /* The value that we sorting by. */ const char *strValuePtr; long intValue; double doubleValue; Tcl_Obj *objValuePtr; } collationKey; - union { /* Object being sorted, or its index. */ - Tcl_Obj *objPtr; - int index; + union { /* Object being sorted, or its index. */ + Tcl_Obj *objPtr; + int index; } payload; struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ @@ -229,8 +229,9 @@ TclNRIfObjCmd( Tcl_Obj *boolObj; if (objc <= 1) { - Tcl_AppendResult(interp, "wrong # args: no expression after \"", - TclGetString(objv[0]), "\" argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no expression after \"%s\" argument", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -319,8 +320,9 @@ IfConditionCallback( */ if (i >= objc) { - Tcl_AppendResult(interp, "wrong # args: ", - "no expression after \"", clause, "\" argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no expression after \"%s\" argument", + clause)); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -345,8 +347,9 @@ IfConditionCallback( } } if (i < objc - 1) { - Tcl_AppendResult(interp, "wrong # args: ", - "extra words after \"else\" clause in \"if\" command", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args: extra words after \"else\" clause in \"if\" command", + -1)); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -361,9 +364,9 @@ IfConditionCallback( return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i); missingScript: - clause = TclGetString(objv[i-1]); - Tcl_AppendResult(interp, "wrong # args: no script following \"", clause, - "\" argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no script following \"%s\" argument", + TclGetString(objv[i-1]))); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -491,7 +494,8 @@ InfoArgsCmd( name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); return TCL_ERROR; } @@ -552,7 +556,8 @@ InfoBodyCmd( name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); return TCL_ERROR; } @@ -981,7 +986,8 @@ InfoDefaultCmd( procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, NULL); return TCL_ERROR; @@ -1012,8 +1018,9 @@ InfoDefaultCmd( } } - Tcl_AppendResult(interp, "procedure \"", procName, - "\" doesn't have an argument \"", argName, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\" doesn't have an argument \"%s\"", + procName, argName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); return TCL_ERROR; } @@ -1055,10 +1062,10 @@ InfoErrorStackCmd( target = interp; if (objc == 2) { - target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); - if (target == NULL) { - return TCL_ERROR; - } + target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + if (target == NULL) { + return TCL_ERROR; + } } iPtr = (Interp *) target; @@ -1158,12 +1165,13 @@ InfoFrameCmd( * A coroutine: must fix the level computations AND the cmdFrame chain, * which is interrupted at the base. */ + CmdFrame *lastPtr = NULL; - runPtr = iPtr->cmdFramePtr; + runPtr = iPtr->cmdFramePtr; /* TODO - deal with overflow */ - topLevel += corPtr->caller.cmdFramePtr->level; + topLevel += corPtr->caller.cmdFramePtr->level; while (runPtr) { runPtr->level += corPtr->caller.cmdFramePtr->level; lastPtr = runPtr; @@ -1196,8 +1204,8 @@ InfoFrameCmd( if ((level > topLevel) || (level <= - topLevel)) { levelError: - Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME", TclGetString(objv[1]), NULL); code = TCL_ERROR; @@ -1401,15 +1409,15 @@ TclInfoFrame( Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; if (namePtr) { - Tcl_Obj *procNameObj; + Tcl_Obj *procNameObj; /* * This is a regular command. */ - TclNewObj(procNameObj); - Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, - procNameObj); + TclNewObj(procNameObj); + Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, + procNameObj); ADD_PAIR("proc", procNameObj); } else if (procPtr->cmdPtr->clientData) { ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; @@ -1538,7 +1546,9 @@ InfoHostnameCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); return TCL_OK; } - Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC); + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to determine name of host", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL); return TCL_ERROR; } @@ -1609,8 +1619,8 @@ InfoLevelCmd( return TCL_ERROR; levelError: - Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", TclGetString(objv[1]), NULL); return TCL_ERROR; @@ -1656,7 +1666,9 @@ InfoLibraryCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); return TCL_OK; } - Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC); + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no library has been specified for Tcl", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL); return TCL_ERROR; } @@ -2590,9 +2602,10 @@ Tcl_LrepeatObjCmd( return TCL_ERROR; } if (elementCount < 0) { - Tcl_SetObjResult(interp, Tcl_Format(NULL, - "bad count \"%d\": must be integer >= 0", 1, objv+1)); - Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPEAT","NEGARG", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad count \"%d\": must be integer >= 0", elementCount)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", + NULL); return TCL_ERROR; } @@ -2608,7 +2621,7 @@ Tcl_LrepeatObjCmd( if (elementCount && objc > LIST_MAX/elementCount) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } totalElems = objc * elementCount; @@ -2723,9 +2736,10 @@ Tcl_LreplaceObjCmd( */ if ((first >= listLen) && (listLen > 0)) { - Tcl_AppendResult(interp, "list doesn't contain element ", - TclGetString(objv[2]), NULL); - Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPLACE","BADIDX", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "list doesn't contain element %s", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX", + NULL); return TCL_ERROR; } if (last >= listLen) { @@ -2996,8 +3010,9 @@ Tcl_LsearchObjCmd( Tcl_DecrRefCount(startPtr); } if (i > objc-4) { - Tcl_AppendResult(interp, "missing starting index", NULL); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing starting index", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); result = TCL_ERROR; goto done; } @@ -3027,10 +3042,10 @@ Tcl_LsearchObjCmd( if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } @@ -3088,18 +3103,18 @@ Tcl_LsearchObjCmd( if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - Tcl_AppendResult(interp, - "-subindices cannot be used without -index option", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-subindices cannot be used without -index option", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BAD_OPTION_MIX", NULL); return TCL_ERROR; } if (bisect && (allMatches || negatedMatch)) { - Tcl_AppendResult(interp, - "-bisect is not compatible with -all or -not", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-bisect is not compatible with -all or -not", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BAD_OPTION_MIX", NULL); return TCL_ERROR; } @@ -3531,7 +3546,7 @@ Tcl_LsetObjCmd( if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, - "listVar ?index? ?index ...? value"); + "listVar ?index? ?index ...? value"); return TCL_ERROR; } @@ -3664,10 +3679,10 @@ Tcl_LsortObjCmd( break; case LSORT_COMMAND: if (i == objc-2) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-command\" option must be followed " - "by comparison command", NULL); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + "by comparison command", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); sortInfo.resultCode = TCL_ERROR; goto done2; } @@ -3685,29 +3700,30 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { - int indexc, dummy; + int indexc, dummy; Tcl_Obj **indexv; if (i == objc-2) { - Tcl_AppendResult(interp, "\"-index\" option must be " - "followed by list index", NULL); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - sortInfo.resultCode = TCL_ERROR; - goto done2; + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-index\" option must be followed by list index", + -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; } if (TclListObjGetElements(interp, objv[i+1], &indexc, &indexv) != TCL_OK) { - sortInfo.resultCode = TCL_ERROR; - goto done2; + sortInfo.resultCode = TCL_ERROR; + goto done2; } - /* - * Check each of the indices for syntactic correctness. Note that - * we do not store the converted values here because we do not - * know if this is the only -index option yet and so we can't - * allocate any space; that happens after the scan through all the - * options is done. - */ + /* + * Check each of the indices for syntactic correctness. Note that + * we do not store the converted values here because we do not + * know if this is the only -index option yet and so we can't + * allocate any space; that happens after the scan through all the + * options is done. + */ for (j=0 ; j= groupSize) { - Tcl_AppendResult(interp, "when used with \"-stride\", the " - "leading \"-index\" value must be within the group", - NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", - "BADINDEX", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "when used with \"-stride\", the leading \"-index\"" + " value must be within the group", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADINDEX", NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4255,11 +4272,10 @@ SortCompare( if (TclGetIntFromObj(infoPtr->interp, Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { - Tcl_ResetResult(infoPtr->interp); - Tcl_AppendResult(infoPtr->interp, - "-compare command returned non-integer result", NULL); - Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "COMPARISONFAILED", NULL); + Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj( + "-compare command returned non-integer result", -1)); + Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", + "COMPARISONFAILED", NULL); infoPtr->resultCode = TCL_ERROR; return 0; } @@ -4470,11 +4486,11 @@ SelectObjFromSublist( return NULL; } if (currentObj == NULL) { - Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( - "element %d missing from sublist \"%s\"", - index, TclGetString(objPtr))); - Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "INDEXFAILED", NULL); + Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( + "element %d missing from sublist \"%s\"", + index, TclGetString(objPtr))); + Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", + "INDEXFAILED", NULL); infoPtr->resultCode = TCL_ERROR; return NULL; } @@ -4489,6 +4505,5 @@ SelectObjFromSublist( * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 - * indent-tabs-mode: nil * End: */ diff --git a/generic/tclConfig.c b/generic/tclConfig.c index dea487a..a4ba71a 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -236,7 +236,7 @@ QueryConfigObjCmd( * present. */ - Tcl_SetResult(interp, "package not known", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", Tcl_GetString(pkgName), NULL); return TCL_ERROR; @@ -251,7 +251,7 @@ QueryConfigObjCmd( if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK || val == NULL) { - Tcl_SetResult(interp, "key not known", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", Tcl_GetString(objv[2]), NULL); return TCL_ERROR; @@ -270,8 +270,8 @@ QueryConfigObjCmd( listPtr = Tcl_NewListObj(n, NULL); if (!listPtr) { - Tcl_SetResult(interp, "insufficient memory to create list", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "insufficient memory to create list", -1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index ac2cb62..691fab9 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -700,7 +700,8 @@ SetDictFromAny( missingValue: if (interp != NULL) { - Tcl_SetResult(interp, "missing value to go with key", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing value to go with key", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); } result = TCL_ERROR; @@ -779,9 +780,9 @@ TclTraceDictPath( } if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(keyv[i]), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(keyv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(keyv[i]), NULL); } @@ -1571,9 +1572,9 @@ DictGetCmd( return result; } if (valuePtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(objv[objc-1]), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(objv[objc-1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(objv[objc-1]), NULL); return TCL_ERROR; @@ -2027,6 +2028,7 @@ DictInfoCmd( { Tcl_Obj *dictPtr; Dict *dict; + char *statsStr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); @@ -2042,7 +2044,9 @@ DictInfoCmd( } dict = dictPtr->internalRep.otherValuePtr; - Tcl_SetResult(interp, Tcl_HashStats(&dict->table), TCL_DYNAMIC); + statsStr = Tcl_HashStats(&dict->table); + Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); + ckfree(statsStr); return TCL_OK; } @@ -2371,8 +2375,8 @@ DictForNRCmd( return TCL_ERROR; } if (varc != 2) { - Tcl_SetResult(interp, "must have exactly two variable names", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have exactly two variable names", -1)); return TCL_ERROR; } searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); @@ -2787,8 +2791,8 @@ DictFilterCmd( return TCL_ERROR; } if (varc != 2) { - Tcl_SetResult(interp, "must have exactly two variable names", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have exactly two variable names", -1)); return TCL_ERROR; } keyVarObj = varv[0]; @@ -2828,16 +2832,19 @@ DictFilterCmd( if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set key variable: \"%s\"", + TclGetString(keyVarObj))); result = TCL_ERROR; goto abnormalResult; } if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set value variable: \"%s\"", + TclGetString(valueVarObj))); + result = TCL_ERROR; goto abnormalResult; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 754e480..b76c603 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -17,6 +17,7 @@ * Declarations for functions local to this file: */ +static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); @@ -78,6 +79,19 @@ const Tcl_ObjType tclEnsembleCmdType = { NULL /* setFromAnyProc */ }; +static inline Tcl_Obj * +NewNsObj( + Tcl_Namespace *namespacePtr) +{ + register Namespace *nsPtr = (Namespace *) namespacePtr; + + if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { + return Tcl_NewStringObj("::", 2); + } else { + return Tcl_NewStringObj(nsPtr->fullName, -1); + } +} + /* *---------------------------------------------------------------------- * @@ -116,9 +130,10 @@ TclNamespaceEnsembleCmd( if (nsPtr == NULL || nsPtr->flags & NS_DYING) { if (!Tcl_InterpDeleted(interp)) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "tried to manipulate ensemble of deleted namespace", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); } return TCL_ERROR; } @@ -235,9 +250,11 @@ TclNamespaceEnsembleCmd( return TCL_ERROR; } if (len < 1) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble subcommand implementations " - "must be non-empty lists", TCL_STATIC); + "must be non-empty lists", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", NULL); Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -250,7 +267,7 @@ TclNamespaceEnsembleCmd( cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_NewListObj(len, listv); - Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1); + Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr); if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); @@ -370,8 +387,7 @@ TclNamespaceEnsembleCmd( case CONF_NAMESPACE: namespacePtr = NULL; /* silence gcc 4 warning */ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_SetResult(interp, ((Namespace *) namespacePtr)->fullName, - TCL_VOLATILE); + Tcl_SetObjResult(interp, NewNsObj(namespacePtr)); break; case CONF_PREFIX: { int flags = 0; /* silence gcc 4 warning */ @@ -411,9 +427,7 @@ TclNamespaceEnsembleCmd( -1)); namespacePtr = NULL; /* silence gcc 4 warning */ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(((Namespace *) namespacePtr)->fullName, - -1)); + Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr)); /* -parameters option */ Tcl_ListObjAppendElement(NULL, resultObj, @@ -515,9 +529,11 @@ TclNamespaceEnsembleCmd( goto freeMapAndError; } if (len < 1) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble subcommand implementations " - "must be non-empty lists", TCL_STATIC); + "must be non-empty lists", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", NULL); Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -527,8 +543,7 @@ TclNamespaceEnsembleCmd( cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_DuplicateObj(listObj); - Tcl_Obj *newCmd = - Tcl_NewStringObj(nsPtr->fullName, -1); + Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr); if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); @@ -554,7 +569,9 @@ TclNamespaceEnsembleCmd( continue; } case CONF_NAMESPACE: - Tcl_AppendResult(interp, "option -namespace is read-only", + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -namespace is read-only", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY", NULL); goto freeMapAndError; case CONF_PREFIX: @@ -629,7 +646,7 @@ Tcl_CreateEnsemble( */ if (!(name[0] == ':' && name[1] == ':')) { - nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); + nameObj = NewNsObj((Tcl_Namespace *) nsPtr); if (nsPtr->parentPtr == NULL) { Tcl_AppendStringsToObj(nameObj, name, NULL); } else { @@ -702,7 +719,9 @@ Tcl_SetEnsembleSubcommandList( Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (subcmdList != NULL) { @@ -776,7 +795,9 @@ Tcl_SetEnsembleParameterList( int length; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (paramList == NULL) { @@ -850,7 +871,9 @@ Tcl_SetEnsembleMappingDict( Tcl_Obj *oldDict; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (mapDict != NULL) { @@ -873,9 +896,11 @@ Tcl_SetEnsembleMappingDict( } bytes = TclGetString(cmdObjPtr); if (bytes[0] != ':' || bytes[1] != ':') { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble target is not a fully-qualified command", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "UNQUALIFIED_TARGET", NULL); Tcl_DictObjDone(&search); return TCL_ERROR; } @@ -945,7 +970,9 @@ Tcl_SetEnsembleUnknownHandler( Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (unknownList != NULL) { @@ -1009,7 +1036,9 @@ Tcl_SetEnsembleFlags( int wasCompiled; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } @@ -1084,7 +1113,9 @@ Tcl_GetEnsembleSubcommandList( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1124,7 +1155,9 @@ Tcl_GetEnsembleParameterList( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1164,7 +1197,9 @@ Tcl_GetEnsembleMappingDict( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1203,7 +1238,9 @@ Tcl_GetEnsembleUnknownHandler( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1242,7 +1279,9 @@ Tcl_GetEnsembleFlags( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1281,7 +1320,9 @@ Tcl_GetEnsembleNamespace( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1337,8 +1378,9 @@ Tcl_FindEnsemble( if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){ if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj), - "\" is not an ensemble command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not an ensemble command", + TclGetString(cmdNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", TclGetString(cmdNameObj), NULL); } @@ -1591,6 +1633,7 @@ NsEnsembleImplementationCmdNR( * specified but not yet cached command * names. */ int reparseCount = 0; /* Number of reparses. */ + Tcl_Obj *errorObj; /* Used for building error messages. */ /* * Must recheck objc, since numParameters might have changed. Cf. test @@ -1631,8 +1674,9 @@ NsEnsembleImplementationCmdNR( */ if (!Tcl_InterpDeleted(interp)) { - Tcl_AppendResult(interp, - "ensemble activated for deleted namespace", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "ensemble activated for deleted namespace", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); } return TCL_ERROR; } @@ -1880,35 +1924,34 @@ NsEnsembleImplementationCmdNR( */ Tcl_ResetResult(interp); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", TclGetString(objv[1+ensemblePtr->numParameters]), NULL); if (ensemblePtr->subcommandTable.numEntries == 0) { - Tcl_AppendResult(interp, "unknown subcommand \"", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown subcommand \"%s\": namespace %s does not" + " export any commands", TclGetString(objv[1+ensemblePtr->numParameters]), - "\": namespace ", ensemblePtr->nsPtr->fullName, - " does not export any commands", NULL); + ensemblePtr->nsPtr->fullName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", TclGetString(objv[1+ensemblePtr->numParameters]), NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "unknown ", - (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), - "subcommand \"", TclGetString(objv[1+ensemblePtr->numParameters]), - "\": must be ", NULL); + errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ", + (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), + TclGetString(objv[1+ensemblePtr->numParameters])); if (ensemblePtr->subcommandTable.numEntries == 1) { - Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1); } else { int i; for (i=0 ; isubcommandTable.numEntries-1 ; i++) { - Tcl_AppendResult(interp, - ensemblePtr->subcommandArrayPtr[i], ", ", NULL); + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1); + Tcl_AppendToObj(errorObj, ", ", 2); } - Tcl_AppendResult(interp, "or ", - ensemblePtr->subcommandArrayPtr[i], NULL); + Tcl_AppendPrintfToObj(errorObj, "or %s", + ensemblePtr->subcommandArrayPtr[i]); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1+ensemblePtr->numParameters]), NULL); + Tcl_SetObjResult(interp, errorObj); return TCL_ERROR; } @@ -2034,7 +2077,6 @@ EnsembleUnknownCallback( { int paramc, i, result, prefixObjc; Tcl_Obj **paramv, *unknownCmd, *ensObj; - char buf[TCL_INTEGER_SPACE]; /* * Create the unknown command callback to determine what to do. @@ -2061,9 +2103,12 @@ EnsembleUnknownCallback( ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT; result = Tcl_EvalObjv(interp, paramc, paramv, 0); if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) { - Tcl_SetResult(interp, - "unknown subcommand handler deleted its ensemble", - TCL_STATIC); + if (!Tcl_InterpDeleted(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown subcommand handler deleted its ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED", + NULL); + } result = TCL_ERROR; } Tcl_Release(ensemblePtr); @@ -2112,26 +2157,26 @@ EnsembleUnknownCallback( if (!Tcl_InterpDeleted(interp)) { if (result != TCL_ERROR) { Tcl_ResetResult(interp); - Tcl_SetResult(interp, - "unknown subcommand handler returned bad code: ", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown subcommand handler returned bad code: ", -1)); switch (result) { case TCL_RETURN: - Tcl_AppendResult(interp, "return", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1); break; case TCL_BREAK: - Tcl_AppendResult(interp, "break", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1); break; case TCL_CONTINUE: - Tcl_AppendResult(interp, "continue", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1); break; default: - sprintf(buf, "%d", result); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result); } Tcl_AddErrorInfo(interp, "\n result of " "ensemble unknown subcommand handler: "); Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT", + NULL); } else { Tcl_AddErrorInfo(interp, "\n (ensemble unknown subcommand handler)"); @@ -2392,7 +2437,7 @@ BuildEnsembleConfig( * the programmer's responsibility (or [::unknown] of course). */ - cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); + cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr); if (ensemblePtr->nsPtr->parentPtr != NULL) { Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); } else { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e402634..3c0b472 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4896,8 +4896,8 @@ TEBCresume( case INST_RSHIFT: if (l2 < 0) { - Tcl_SetResult(interp, "negative shift argument", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); #if 0 DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", @@ -4944,8 +4944,8 @@ TEBCresume( case INST_LSHIFT: if (l2 < 0) { - Tcl_SetResult(interp, "negative shift argument", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); #if 0 DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", @@ -4967,9 +4967,8 @@ TEBCresume( * good place to draw the line. */ - Tcl_SetResult(interp, - "integer value too large to represent", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); #if 0 DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", @@ -5671,9 +5670,9 @@ TEBCresume( NEXT_INST_V(5, opnd+1, 1); } DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(OBJ_AT_TOS), NULL); CACHE_STACK_INFO(); @@ -6304,7 +6303,7 @@ TEBCresume( divideByZero: DECACHE_STACK_INFO(); - Tcl_SetResult(interp, "divide by zero", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); CACHE_STACK_INFO(); goto gotError; @@ -6316,8 +6315,8 @@ TEBCresume( exponOfZero: DECACHE_STACK_INFO(); - Tcl_SetResult(interp, "exponentiation of zero by negative power", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponentiation of zero by negative power", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); CACHE_STACK_INFO(); @@ -6693,7 +6692,8 @@ ExecuteExtendedBinaryMathOp( invalid = 0; } if (invalid) { - Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); return GENERAL_ARITHMETIC_ERROR; } @@ -6723,8 +6723,8 @@ ExecuteExtendedBinaryMathOp( * place to draw the line. */ - Tcl_SetResult(interp, "integer value too large to represent", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } shift = (int)(*((const long *)ptr2)); @@ -7125,7 +7125,8 @@ ExecuteExtendedBinaryMathOp( */ if (type2 != TCL_NUMBER_LONG) { - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } @@ -7363,7 +7364,8 @@ ExecuteExtendedBinaryMathOp( Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if (big2.used > 1) { mp_clear(&big2); - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); diff --git a/generic/tclFileName.c b/generic/tclFileName.c index edb6581..5d90351 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1174,9 +1174,10 @@ DoTildeSubst( dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't find HOME environment " - "variable to expand path", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment " + "variable to expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL); } return NULL; } @@ -1185,8 +1186,9 @@ DoTildeSubst( } else if (TclpGetUserHome(user, resultPtr) == NULL) { if (interp) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", user)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL); } return NULL; } @@ -1329,9 +1331,9 @@ Tcl_GlobObjCmd( endOfForLoop: if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-tails\" must be used with either " - "\"-directory\" or \"-path\"", NULL); + "\"-directory\" or \"-path\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; @@ -1625,20 +1627,23 @@ Tcl_GlobObjCmd( } if (length == 0) { - Tcl_AppendResult(interp, "no files matched glob pattern", - (join || (objc == 1)) ? " \"" : "s \"", NULL); + Tcl_Obj *errorMsg = + Tcl_ObjPrintf("no files matched glob pattern%s \"", + (join || (objc == 1)) ? "" : "s"); + if (join) { - Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL); + Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1); } else { const char *sep = ""; for (i = 0; i < objc; i++) { - string = Tcl_GetString(objv[i]); - Tcl_AppendResult(interp, sep, string, NULL); + Tcl_AppendPrintfToObj(errorMsg, "%s%s", + sep, Tcl_GetString(objv[i])); sep = " "; } } - Tcl_AppendResult(interp, "\"", NULL); + Tcl_AppendToObj(errorMsg, "\"", -1); + Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", NULL); result = TCL_ERROR; @@ -2206,15 +2211,15 @@ DoGlob( closeBrace = p; break; } - Tcl_SetResult(interp, "unmatched open-brace in file name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched open-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", NULL); return TCL_ERROR; } else if (*p == '}') { - Tcl_SetResult(interp, "unmatched close-brace in file name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched close-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", NULL); return TCL_ERROR; diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 6fec40a..eeb11f9 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -739,7 +739,8 @@ TclChanCreateObjCmd( * Return handle as result of command. */ - Tcl_SetResult(interp, (char *)chanPtr->state->channelName, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(chanPtr->state->channelName, -1)); return TCL_OK; error: diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 41a5aac..ebf34dc 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1094,8 +1094,9 @@ Tcl_FSMatchInDirectory( cwd = Tcl_FSGetCwd(NULL); if (cwd == NULL) { if (interp != NULL) { - Tcl_SetResult(interp, "glob couldn't determine " - "the current working directory", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "glob couldn't determine the current working directory", + -1)); } return TCL_ERROR; } diff --git a/generic/tclLoad.c b/generic/tclLoad.c index ce4d6a4..f14cec0 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -157,9 +157,8 @@ Tcl_LoadObjCmd( } } if ((fullFileName[0] == 0) && (packageName == NULL)) { - Tcl_SetResult(interp, - "must specify either file name or package name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must specify either file name or package name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -581,9 +580,8 @@ Tcl_UnloadObjCmd( } } if ((fullFileName[0] == 0) && (packageName == NULL)) { - Tcl_SetResult(interp, - "must specify either file name or package name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must specify either file name or package name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", NULL); code = TCL_ERROR; diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index ac094e6..6b48aee 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -44,9 +44,9 @@ TclpDlopen( * function which should be used for this * file. */ { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "dynamic loading is not currently available on this system", - TCL_STATIC); + -1)); return TCL_ERROR; } diff --git a/generic/tclOO.c b/generic/tclOO.c index df7d49d..d9f5d60 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1582,8 +1582,9 @@ Tcl_NewObjectInstance( if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, TCL_NAMESPACE_ONLY)) { - Tcl_AppendResult(interp, "can't create object \"", nameStr, - "\": command already exists with that name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); return NULL; } @@ -1649,8 +1650,8 @@ Tcl_NewObjectInstance( */ if (result != TCL_ERROR && Deleted(oPtr)) { - Tcl_SetResult(interp, "object deleted in constructor", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object deleted in constructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); result = TCL_ERROR; } @@ -1705,8 +1706,9 @@ TclNRNewObjectInstance( if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, TCL_NAMESPACE_ONLY)) { - Tcl_AppendResult(interp, "can't create object \"", nameStr, - "\": command already exists with that name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); return TCL_ERROR; } @@ -1794,7 +1796,8 @@ FinalizeAlloc( */ if (result != TCL_ERROR && Deleted(oPtr)) { - Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object deleted in constructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); result = TCL_ERROR; } @@ -1851,7 +1854,8 @@ Tcl_CopyObjectInstance( */ if (IsRootClass(oPtr)) { - Tcl_AppendResult(interp, "may not clone the class of classes", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not clone the class of classes", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL); return NULL; } @@ -2514,9 +2518,9 @@ TclOOObjectCmdCore( flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { - Tcl_AppendResult(interp, "impossible to invoke method \"", - TclGetString(methodNamePtr), - "\": no defined method or unknown method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "impossible to invoke method \"%s\": no defined method or" + " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED", TclGetString(methodNamePtr), NULL); return TCL_ERROR; @@ -2530,9 +2534,9 @@ TclOOObjectCmdCore( contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, flags | (oPtr->flags & FILTER_HANDLING), NULL); if (contextPtr == NULL) { - Tcl_AppendResult(interp, "impossible to invoke method \"", - TclGetString(methodNamePtr), - "\": no defined method or unknown method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "impossible to invoke method \"%s\": no defined method or" + " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(methodNamePtr), NULL); return TCL_ERROR; @@ -2558,8 +2562,8 @@ TclOOObjectCmdCore( } } if (contextPtr->index >= contextPtr->callPtr->numChain) { - Tcl_SetResult(interp, "no valid method implementation", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no valid method implementation", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(methodNamePtr), NULL); TclOODeleteContext(contextPtr); @@ -2640,8 +2644,8 @@ Tcl_ObjectContextInvokeNext( methodType = "method"; } - Tcl_AppendResult(interp, "no next ", methodType, " implementation", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); return TCL_ERROR; } @@ -2709,8 +2713,8 @@ TclNRObjectContextInvokeNext( methodType = "method"; } - Tcl_AppendResult(interp, "no next ", methodType, " implementation", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); return TCL_ERROR; } @@ -2787,8 +2791,8 @@ Tcl_GetObjectFromObj( return cmdPtr->objClientData; notAnObject: - Tcl_AppendResult(interp, TclGetString(objPtr), - " does not refer to an object", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s does not refer to an object", TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr), NULL); return NULL; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 35ad1eb..3637ede 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -168,8 +168,8 @@ TclOO_Class_Create( if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" is not a class", TclGetString(cmdnameObj))); Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); return TCL_ERROR; } @@ -186,7 +186,8 @@ TclOO_Class_Create( objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { - Tcl_AppendResult(interp, "object name must not be empty", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } @@ -232,8 +233,8 @@ TclOO_Class_CreateNs( if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" is not a class", TclGetString(cmdnameObj))); Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); return TCL_ERROR; } @@ -250,14 +251,16 @@ TclOO_Class_CreateNs( objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { - Tcl_AppendResult(interp, "object name must not be empty", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } nsName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)+1], &len); if (len == 0) { - Tcl_AppendResult(interp, "namespace name must not be empty", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "namespace name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } @@ -301,8 +304,8 @@ TclOO_Class_New( if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" is not a class", TclGetString(cmdnameObj))); Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); return TCL_ERROR; } @@ -504,6 +507,7 @@ TclOO_Object_Unknown( Object *oPtr = contextPtr->oPtr; const char **methodNames; int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); + Tcl_Obj *errorMsg; /* * If no method name, generate an error asking for a method name. (Only by @@ -529,31 +533,34 @@ TclOO_Object_Unknown( if (numMethodNames == 0) { Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr); + const char *piece; - Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL); if (contextPtr->callPtr->flags & PUBLIC_METHOD) { - Tcl_AppendResult(interp, "\" has no visible methods", NULL); + piece = "visible methods"; } else { - Tcl_AppendResult(interp, "\" has no methods", NULL); + piece = "methods"; } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" has no %s", TclGetString(tmpBuf), piece)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[skip]), NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]), - "\": must be ", NULL); + errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ", + TclGetString(objv[skip])); for (i=0 ; iisProcCallFrame & FRAME_IS_METHOD)) { - Tcl_AppendResult(interp, TclGetString(objv[0]), - " may only be called from inside a method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } @@ -822,8 +831,9 @@ TclOONextToObjCmd( */ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - Tcl_AppendResult(interp, TclGetString(objv[0]), - " may only be called from inside a method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } @@ -843,8 +853,9 @@ TclOONextToObjCmd( } classPtr = ((Object *)object)->classPtr; if (classPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); return TCL_ERROR; } @@ -881,14 +892,15 @@ TclOONextToObjCmd( struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { - Tcl_AppendResult(interp, "method implementation by \"", - TclGetString(objv[1]), "\" not reachable from here", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method implementation by \"%s\" not reachable from here", + TclGetString(objv[1]))); return TCL_ERROR; } } - Tcl_AppendResult(interp, "method has no non-filter implementation by \"", - TclGetString(objv[1]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method has no non-filter implementation by \"%s\"", + TclGetString(objv[1]))); return TCL_ERROR; } @@ -948,8 +960,9 @@ TclOOSelfObjCmd( */ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - Tcl_AppendResult(interp, TclGetString(objv[0]), - " may only be called from inside a method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } @@ -983,7 +996,8 @@ TclOOSelfObjCmd( Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; if (clsPtr == NULL) { - Tcl_AppendResult(interp, "method not defined by a class", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method not defined by a class", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } @@ -1003,7 +1017,8 @@ TclOOSelfObjCmd( return TCL_OK; case SELF_FILTER: if (!CurrentlyInvoked(contextPtr).isFilter) { - Tcl_AppendResult(interp, "not inside a filtering context", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "not inside a filtering context", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } else { @@ -1028,7 +1043,8 @@ TclOOSelfObjCmd( case SELF_CALLER: if ((framePtr->callerVarPtr == NULL) || !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){ - Tcl_AppendResult(interp, "caller is not an object", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "caller is not an object", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } else { @@ -1045,7 +1061,8 @@ TclOOSelfObjCmd( * This should be unreachable code. */ - Tcl_AppendResult(interp, "method without declarer!", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method without declarer!", -1)); return TCL_ERROR; } @@ -1076,7 +1093,8 @@ TclOOSelfObjCmd( * This should be unreachable code. */ - Tcl_AppendResult(interp, "method without declarer!", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method without declarer!", -1)); return TCL_ERROR; } @@ -1093,7 +1111,8 @@ TclOOSelfObjCmd( return TCL_OK; case SELF_TARGET: if (!CurrentlyInvoked(contextPtr).isFilter) { - Tcl_AppendResult(interp, "not inside a filtering context", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "not inside a filtering context", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } else { @@ -1119,7 +1138,8 @@ TclOOSelfObjCmd( * This should be unreachable code. */ - Tcl_AppendResult(interp, "method without declarer!", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method without declarer!", -1)); return TCL_ERROR; } result[0] = TclOOObjectName(interp, declarerPtr); diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 69cffb0..c022e6b 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -423,8 +423,8 @@ RenameDeleteMethod( if (!useClass) { if (!oPtr->methodsPtr) { noSuchMethod: - Tcl_AppendResult(interp, "method ", TclGetString(fromPtr), - " does not exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method %s does not exist", TclGetString(fromPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(fromPtr), NULL); return TCL_ERROR; @@ -438,14 +438,15 @@ RenameDeleteMethod( &isNew); if (hPtr == newHPtr) { renameToSelf: - Tcl_AppendResult(interp, "cannot rename method to itself", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot rename method to itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL); return TCL_ERROR; } else if (!isNew) { renameToExisting: - Tcl_AppendResult(interp, "method called ", - TclGetString(toPtr), " already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method called %s already exists", + TclGetString(toPtr))); Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL); return TCL_ERROR; } @@ -513,7 +514,8 @@ TclOOUnknownDefinition( const char *soughtStr, *matchedStr = NULL; if (objc < 2) { - Tcl_AppendResult(interp, "bad call of unknown handler", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad call of unknown handler", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL); return TCL_ERROR; } @@ -558,7 +560,8 @@ TclOOUnknownDefinition( } noMatch: - Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", soughtStr)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL); return TCL_ERROR; } @@ -646,9 +649,9 @@ InitDefineContext( int result; if (namespacePtr == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot process definitions; support namespace deleted", - NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -686,16 +689,17 @@ TclOOGetDefineCmdContext( if ((iPtr->varFramePtr == NULL) || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { - Tcl_AppendResult(interp, "this command may only be called from within" - " the context of an ::oo::define or ::oo::objdefine command", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "this command may only be called from within the context of" + " an ::oo::define or ::oo::objdefine command", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return NULL; } object = iPtr->varFramePtr->clientData; if (Tcl_ObjectDeleted(object)) { - Tcl_AppendResult(interp, "this command cannot be called when the " - "object has been deleted", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "this command cannot be called when the object has been" + " deleted", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return NULL; } @@ -736,7 +740,7 @@ GetClassInOuterContext( return NULL; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(className), NULL); return NULL; @@ -816,8 +820,8 @@ TclOODefineObjCmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, TclGetString(objv[1]), - " does not refer to a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s does not refer to a class",TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[1]), NULL); return TCL_ERROR; @@ -1161,14 +1165,14 @@ TclOODefineClassObjCmd( return TCL_ERROR; } if (oPtr->flags & ROOT_OBJECT) { - Tcl_AppendResult(interp, - "may not modify the class of the root object class", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the class of the root object class", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } if (oPtr->flags & ROOT_CLASS) { - Tcl_AppendResult(interp, - "may not modify the class of the class of classes", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the class of the class of classes", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1194,9 +1198,10 @@ TclOODefineClassObjCmd( */ if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) { - Tcl_AppendResult(interp, "may not change a ", - (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ", - (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "may not change a %sclass object into a %sclass object", + (oPtr->classPtr==NULL ? "non-" : ""), + (oPtr->classPtr==NULL ? "" : "non-"))); Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL); return TCL_ERROR; } @@ -1317,7 +1322,8 @@ TclOODefineDeleteMethodObjCmd( return TCL_ERROR; } if (!isInstanceDeleteMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1440,7 +1446,8 @@ TclOODefineExportObjCmd( } clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1531,7 +1538,8 @@ TclOODefineForwardObjCmd( return TCL_ERROR; } if (!isInstanceForward && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1588,7 +1596,8 @@ TclOODefineMethodObjCmd( return TCL_ERROR; } if (!isInstanceMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1639,7 +1648,8 @@ TclOODefineMixinObjCmd( return TCL_ERROR; } if (!isInstanceMixin && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1653,7 +1663,8 @@ TclOODefineMixinObjCmd( goto freeAndError; } if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) { - Tcl_AppendResult(interp, "may not mix a class into itself", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not mix a class into itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } @@ -1704,7 +1715,8 @@ TclOODefineRenameMethodObjCmd( return TCL_ERROR; } if (!isInstanceRenameMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1764,7 +1776,8 @@ TclOODefineUnexportObjCmd( } clsPtr = oPtr->classPtr; if (!isInstanceUnexport && !clsPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1949,7 +1962,8 @@ ClassFilterGet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1984,7 +1998,8 @@ ClassFilterSet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc, @@ -2027,7 +2042,8 @@ ClassMixinGet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -2065,7 +2081,8 @@ ClassMixinSet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, @@ -2082,7 +2099,8 @@ ClassMixinSet( goto freeAndError; } if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { - Tcl_AppendResult(interp, "may not mix a class into itself", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not mix a class into itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } @@ -2128,7 +2146,8 @@ ClassSuperGet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -2165,12 +2184,13 @@ ClassSuperSet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) { - Tcl_AppendResult(interp, - "may not modify the superclass of the root object", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the superclass of the root object", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } else if (Tcl_ListObjGetElements(interp, objv[0], &superc, @@ -2196,15 +2216,15 @@ ClassSuperSet( } for (j=0 ; jclassPtr, superclasses[i])) { - Tcl_AppendResult(interp, - "attempt to form circular dependency graph", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to form circular dependency graph", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); failedAfterAlloc: ckfree((char *) superclasses); @@ -2265,7 +2285,8 @@ ClassVarsGet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -2301,7 +2322,8 @@ ClassVarsSet( if (oPtr == NULL) { return TCL_ERROR; } else if (!oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, @@ -2313,15 +2335,16 @@ ClassVarsSet( const char *varName = Tcl_GetString(varv[i]); if (strstr(varName, "::") != NULL) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not contain namespace separators", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "contain namespace separators")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); return TCL_ERROR; } if (Tcl_StringMatch(varName, "*(*)")) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not refer to an array element", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "refer to an array element")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); return TCL_ERROR; } @@ -2591,15 +2614,16 @@ ObjVarsSet( const char *varName = Tcl_GetString(varv[i]); if (strstr(varName, "::") != NULL) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not contain namespace separators", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "contain namespace separators")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); return TCL_ERROR; } if (Tcl_StringMatch(varName, "*(*)")) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not refer to an array element", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "refer to an array element")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); return TCL_ERROR; } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index f298320..796442b 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -177,8 +177,8 @@ GetClassFromObj( return NULL; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objPtr), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objPtr), NULL); return NULL; @@ -279,16 +279,16 @@ InfoObjectDefnCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -390,17 +390,17 @@ InfoObjectForwardCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", - NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -491,7 +491,8 @@ InfoObjectIsACmd( return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "non-classes cannot be mixins", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); return TCL_ERROR; } else { @@ -516,7 +517,8 @@ InfoObjectIsACmd( return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "non-classes cannot be types", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "non-classes cannot be types", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); return TCL_ERROR; } @@ -651,8 +653,8 @@ InfoObjectMethodTypeCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -878,8 +880,8 @@ InfoClassConstrCmd( } procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); return TCL_ERROR; } @@ -937,16 +939,16 @@ InfoClassDefnCmd( } hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -1006,8 +1008,8 @@ InfoClassDestrCmd( } procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); return TCL_ERROR; } @@ -1085,17 +1087,17 @@ InfoClassForwardCmd( } hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", - NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -1269,8 +1271,8 @@ InfoClassMethodTypeCmd( hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -1494,7 +1496,8 @@ InfoObjectCallCmd( contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); if (contextPtr == NULL) { - Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct any call chain", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, @@ -1538,7 +1541,8 @@ InfoClassCallCmd( callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD); if (callPtr == NULL) { - Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct any call chain", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr)); diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 877c3db..60eaa6e 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1329,8 +1329,8 @@ TclOONewForwardInstanceMethod( return NULL; } if (prefixLen < 1) { - Tcl_AppendResult(interp, "method forward prefix must be non-empty", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method forward prefix must be non-empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } @@ -1371,8 +1371,8 @@ TclOONewForwardMethod( return NULL; } if (prefixLen < 1) { - Tcl_AppendResult(interp, "method forward prefix must be non-empty", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method forward prefix must be non-empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index 3b6ce37..55f2378 100644 --- a/generic/tclOOStubLib.c +++ b/generic/tclOOStubLib.c @@ -53,8 +53,9 @@ TclOOInitializeStubs( if (clientData == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "Error loading ", packageName, " package; ", - "package not present or incomplete", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error loading %s package; package not present or incomplete", + packageName)); return NULL; } else { const TclOOStubs * const stubsPtr = clientData; @@ -76,9 +77,9 @@ TclOOInitializeStubs( error: Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "Error loading ", packageName, " package", - " (requested version '", version, "', loaded version '", - actualVersion, "'): ", errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Error loading %s package" + " (requested version '%s', loaded version '%s'): %s", + packageName, version, actualVersion, errMsg)); return NULL; } } diff --git a/generic/tclParse.c b/generic/tclParse.c index f0050c6..aab2fac 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -258,7 +258,8 @@ Tcl_ParseCommand( if ((start == NULL) && (numBytes != 0)) { if (interp != NULL) { - Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't parse a NULL pointer", -1)); } return TCL_ERROR; } @@ -568,14 +569,14 @@ Tcl_ParseCommand( } if (src[-1] == '"') { if (interp != NULL) { - Tcl_SetResult(interp, "extra characters after close-quote", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-quote", -1)); } parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; } else { if (interp != NULL) { - Tcl_SetResult(interp, "extra characters after close-brace", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-brace", -1)); } parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; } @@ -1175,8 +1176,8 @@ ParseTokens( } if (numBytes == 0) { if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, - "missing close-bracket", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing close-bracket", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; @@ -1411,8 +1412,8 @@ Tcl_ParseVarName( } if (numBytes == 0) { if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, - "missing close-brace for variable name", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing close-brace for variable name", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE; parsePtr->term = tokenPtr->start-1; @@ -1479,8 +1480,8 @@ Tcl_ParseVarName( } if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){ if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, "missing )", - TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing )", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_PAREN; parsePtr->term = src; @@ -1755,7 +1756,8 @@ Tcl_ParseBraces( goto error; } - Tcl_SetResult(parsePtr->interp, "missing close-brace", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing close-brace", -1)); /* * Guess if the problem is due to comments by searching the source string @@ -1857,7 +1859,8 @@ Tcl_ParseQuotedString( } if (*parsePtr->term != '"') { if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing \"", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_QUOTE; parsePtr->term = start; diff --git a/generic/tclPipe.c b/generic/tclPipe.c index d0b136d..56a1846 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -542,8 +542,8 @@ TclCreatePipeline( } if (*p == '\0') { if ((i == (lastBar + 1)) || (i == (argc - 1))) { - Tcl_SetResult(interp, "illegal use of | or |& in command", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal use of | or |& in command", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", NULL); goto error; @@ -722,8 +722,8 @@ TclCreatePipeline( * We had a bar followed only by redirections. */ - Tcl_SetResult(interp, "illegal use of | or |& in command", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal use of | or |& in command", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", NULL); goto error; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 382ffe3..730efec 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -850,7 +850,8 @@ Tcl_PackageObjCmd( if (res == 0){ if (objc == 4) { ckfree(argv3i); - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(availPtr->script, -1)); return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); @@ -955,7 +956,8 @@ Tcl_PackageObjCmd( if (hPtr != NULL) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(pkgPtr->version, -1)); } } return TCL_OK; @@ -1017,7 +1019,8 @@ Tcl_PackageObjCmd( if (objc == 2) { if (iPtr->packageUnknown != NULL) { - Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(iPtr->packageUnknown, -1)); } } else if (objc == 3) { if (iPtr->packageUnknown != NULL) { diff --git a/generic/tclScan.c b/generic/tclScan.c index d21bfaf..ef7eedf 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -261,6 +261,10 @@ ValidateFormat( int objIndex, xpgSize, nspace = numVars; int *nassign = TclStackAlloc(interp, nspace * sizeof(int)); char buf[TCL_UTF_MAX+1]; + Tcl_Obj *errorMsg; /* Place to build an error messages. Note that + * these are messy operations because we do + * not want to use the formatting engine; + * we're inside there! */ /* * Initialize an array that records the number of times a variable is @@ -328,9 +332,9 @@ ValidateFormat( gotSequential = 1; if (gotXpg) { mixedXPG: - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot mix \"%\" and \"%n$\" conversion specifiers", - TCL_STATIC); + -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL); goto error; } @@ -375,9 +379,9 @@ ValidateFormat( switch (ch) { case 'c': if (flags & SCAN_WIDTH) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "field width may not be specified in %c conversion", - TCL_STATIC); + -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL); goto error; } @@ -389,9 +393,11 @@ ValidateFormat( if (flags & (SCAN_LONGER|SCAN_BIG)) { invalidFieldSize: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, - "field size modifier may not be specified in %", buf, - " conversion", NULL); + errorMsg = Tcl_NewStringObj( + "field size modifier may not be specified in %", -1); + Tcl_AppendToObj(errorMsg, buf, -1); + Tcl_AppendToObj(errorMsg, " conversion", -1); + Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL); goto error; } @@ -409,8 +415,8 @@ ValidateFormat( break; case 'u': if (flags & SCAN_BIG) { - Tcl_SetResult(interp, - "unsigned bignum scans are invalid", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unsigned bignum scans are invalid", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); goto error; } @@ -446,15 +452,18 @@ ValidateFormat( } break; badSet: - Tcl_SetResult(interp, "unmatched [ in format string", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched [ in format string", -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL); goto error; default: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, "bad scan conversion character \"", buf, - "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); + errorMsg = Tcl_NewStringObj( + "bad scan conversion character \"", -1); + Tcl_AppendToObj(errorMsg, buf, -1); + Tcl_AppendToObj(errorMsg, "\"", -1); + Tcl_SetObjResult(interp, errorMsg); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); goto error; } if (!(flags & SCAN_SUPPRESS)) { @@ -498,9 +507,9 @@ ValidateFormat( } for (i = 0; i < numVars; i++) { if (nassign[i] > 1) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "variable is assigned by multiple \"%n$\" conversion specifiers", - TCL_STATIC); + -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL); goto error; } else if (!xpgSize && (nassign[i] == 0)) { @@ -509,9 +518,9 @@ ValidateFormat( * and/or numVars != 0), then too many vars were given */ - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "variable is not assigned by any conversion specifiers", - TCL_STATIC); + -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL); goto error; } @@ -522,13 +531,13 @@ ValidateFormat( badIndex: if (gotXpg) { - Tcl_SetResult(interp, "\"%n$\" argument index out of range", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"%n$\" argument index out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL); } else { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "different numbers of variable names and field specifiers", - TCL_STATIC); + -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL); } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 529c38a..3888549 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -434,9 +434,9 @@ TraceExecutionObjCmd( return result; } if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of enter, leave, enterstep, or leavestep", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad operation list \"\": must be one or more of" + " enter, leave, enterstep, or leavestep", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", NULL); return TCL_ERROR; @@ -677,8 +677,9 @@ TraceCommandObjCmd( return result; } if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of delete or rename", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad operation list \"\": must be one or more of" + " delete or rename", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", NULL); return TCL_ERROR; @@ -875,8 +876,9 @@ TraceVariableObjCmd( return result; } if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of array, read, unset, or write", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad operation list \"\": must be one or more of" + " array, read, unset, or write", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", NULL); return TCL_ERROR; @@ -2715,7 +2717,8 @@ TclCallVarTraces( if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result); } else { - Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC); + Tcl_SetObjResult((Tcl_Interp *)iPtr, + Tcl_NewStringObj(result, -1)); } Tcl_AddErrorInfo((Tcl_Interp *)iPtr, ""); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 63c9fb2..6d42080 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -655,16 +655,16 @@ TclFindElement( if (p == limit) { if (openBraces != 0) { if (interp != NULL) { - Tcl_SetResult(interp, "unmatched open brace in list", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched open brace in list", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { - Tcl_SetResult(interp, "unmatched open quote in list", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched open quote in list", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", NULL); } @@ -810,8 +810,8 @@ Tcl_SplitList( if (i >= size) { ckfree(argv); if (interp != NULL) { - Tcl_SetResult(interp, "internal error in Tcl_SplitList", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "internal error in Tcl_SplitList", -1)); Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", NULL); } @@ -3382,16 +3382,10 @@ TclGetIntForIndex( parseError: if (interp != NULL) { - /* - * The result might not be empty; this resets it which should be both - * a cheap operation, and of little problem because this is an - * error-generation path anyway. - */ - bytes = Tcl_GetString(objPtr); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be integer?[+-]integer? or end?[+-]integer?", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be integer?[+-]integer? or" + " end?[+-]integer?", bytes)); if (!strncmp(bytes, "end-", 4)) { bytes += 4; } @@ -3483,9 +3477,8 @@ SetEndOffsetFromAny( if ((*bytes != 'e') || (strncmp(bytes, "end", (size_t)((length > 3) ? 3 : length)) != 0)) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be end?[+-]integer?", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be end?[+-]integer?", bytes)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; @@ -3519,9 +3512,8 @@ SetEndOffsetFromAny( badIndexFormat: if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be end?[+-]integer?", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be end?[+-]integer?", bytes)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; @@ -3597,8 +3589,8 @@ TclCheckBadOctal( * be added to an existing error message as extra info. */ - Tcl_AppendResult(interp, " (looks like invalid octal number)", - NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + " (looks like invalid octal number)", -1); } return 1; } @@ -4214,7 +4206,7 @@ TclReToGlob( invalidGlob: if (interp != NULL) { - Tcl_AppendResult(interp, msg, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); } Tcl_DStringFree(dsPtr); diff --git a/generic/tclVar.c b/generic/tclVar.c index e92dc5f..e31e9cf 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3065,7 +3065,8 @@ ArrayStartSearchCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", varName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); return TCL_ERROR; } @@ -3160,8 +3161,8 @@ ArrayAnyMoreCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -3266,8 +3267,8 @@ ArrayNextElementCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -3376,8 +3377,8 @@ ArrayDoneSearchCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -4019,8 +4020,8 @@ ArrayStatsCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -4028,7 +4029,8 @@ ArrayStatsCmd( stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); if (stats == NULL) { - Tcl_SetResult(interp, "error reading array statistics", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error reading array statistics", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); @@ -4317,10 +4319,10 @@ ObjMakeUpvar( || (varFramePtr == NULL) || !HasLocalVars(varFramePtr) || (strstr(TclGetString(myNamePtr), "::") != NULL))) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - TclGetString(myNamePtr), "\": upvar won't create " + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "bad variable name \"%s\": upvar won't create " "namespace variable that refers to procedure variable", - NULL); + TclGetString(myNamePtr))); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); return TCL_ERROR; } @@ -4418,9 +4420,10 @@ TclPtrObjMakeUpvar( * myName looks like an array reference. */ - Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": upvar won't create a scalar variable " - "that looks like an array element", NULL); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "bad variable name \"%s\": upvar won't create a" + " scalar variable that looks like an array element", + myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); return TCL_ERROR; @@ -4447,15 +4450,15 @@ TclPtrObjMakeUpvar( } if (varPtr == otherPtr) { - Tcl_SetResult((Tcl_Interp *) iPtr, - "can't upvar from variable to itself", TCL_STATIC); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj( + "can't upvar from variable to itself", -1)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL); return TCL_ERROR; } if (TclIsVarTraced(varPtr)) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" has traces: can't use for upvar", NULL); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "variable \"%s\" has traces: can't use for upvar", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL); return TCL_ERROR; } else if (!TclIsVarUndefined(varPtr)) { @@ -4469,8 +4472,8 @@ TclPtrObjMakeUpvar( */ if (!TclIsVarLink(varPtr)) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" already exists", NULL); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "variable \"%s\" already exists", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL); return TCL_ERROR; } @@ -4968,8 +4971,8 @@ Tcl_UpvarObjCmd( * for this particular case. */ - Tcl_AppendResult(interp, "bad level \"", TclGetString(levelObj), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(levelObj))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL); return TCL_ERROR; } @@ -4978,8 +4981,8 @@ Tcl_UpvarObjCmd( * We've now finished with parsing levels; skip to the variable names. */ - objc -= hasLevel+1; - objv += hasLevel+1; + objc -= hasLevel + 1; + objv += hasLevel + 1; /* * Iterate over each (other variable, local variable) pair. Divide the @@ -5060,8 +5063,8 @@ SetArraySearchObj( return TCL_OK; syntax: - Tcl_AppendResult(interp, "illegal search identifier \"", string, "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal search identifier \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); return TCL_ERROR; } @@ -5126,10 +5129,9 @@ ParseSearchId( */ if (strcmp(string+offset, varName) != 0) { - Tcl_AppendResult(interp, "search identifier \"", string, - "\" isn't for variable \"", varName, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "search identifier \"%s\" isn't for variable \"%s\"", + string, varName)); goto badLookup; } @@ -5153,7 +5155,8 @@ ParseSearchId( } } } - Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find search \"%s\"", string)); badLookup: Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); return NULL; @@ -5894,8 +5897,8 @@ ObjFindNamespaceVar( Tcl_DecrRefCount(simpleNamePtr); } if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown variable \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL); } return (Tcl_Var) varPtr; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index a799639..8a57a91 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -577,8 +577,8 @@ Tcl_ZlibStreamInit( TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp)); if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname), &cmdinfo) == 1) { - Tcl_SetResult(interp, - "BUG: Stream command name already exists", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "BUG: Stream command name already exists", -1)); Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL); Tcl_DStringFree(&cmdname); goto error; @@ -900,8 +900,8 @@ Tcl_ZlibStreamPut( if (zshPtr->streamEnd) { if (zshPtr->interp) { - Tcl_SetResult(zshPtr->interp, - "already past compressed stream end", TCL_STATIC); + Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj( + "already past compressed stream end", -1)); Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL); } return TCL_ERROR; @@ -1085,9 +1085,9 @@ Tcl_ZlibStreamGet( if (zshPtr->stream.avail_in > 0) { if (zshPtr->interp) { - Tcl_SetResult(zshPtr->interp, - "Unexpected zlib internal state during decompression", - TCL_STATIC); + Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj( + "unexpected zlib internal state during" + " decompression", -1)); Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE", NULL); } @@ -2581,8 +2581,9 @@ ZlibTransformSetOption( /* not used */ } else if (value[0] == 's' && strcmp(value, "sync") == 0) { flushType = Z_SYNC_FLUSH; } else { - Tcl_AppendResult(interp, "unknown -flush type \"", value, - "\": must be full or sync", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown -flush type \"%s\": must be full or sync", + value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL); return TCL_ERROR; } @@ -3152,7 +3153,7 @@ Tcl_ZlibStreamInit( Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle) { - Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); return TCL_ERROR; } @@ -3218,7 +3219,7 @@ Tcl_ZlibDeflate( int level, Tcl_Obj *gzipHeaderDictObj) { - Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); return TCL_ERROR; } @@ -3231,7 +3232,7 @@ Tcl_ZlibInflate( int bufferSize, Tcl_Obj *gzipHeaderDictObj) { - Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); return TCL_ERROR; } diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 1cd6c46..4d6e31b 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1648,9 +1648,9 @@ DdeObjCmd( */ if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) { - Tcl_SetResult(riPtr->interp, "permission denied: " - "a handler procedure must be defined for use in " - "a safe interp", TCL_STATIC); + Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( + "permission denied: a handler procedure must be" + " defined for use in a safe interp", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK", NULL); result = TCL_ERROR; -- cgit v0.12 From 73f7530a3ae011d053337dd067211c96898f71bc Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 3 Aug 2012 14:24:34 +0000 Subject: more result generation conversion --- generic/tclBinary.c | 24 ++++---- generic/tclCkalloc.c | 53 +++++++++-------- generic/tclClock.c | 8 +-- generic/tclCmdAH.c | 39 +++++++------ generic/tclCmdMZ.c | 94 ++++++++++++++++-------------- generic/tclEncoding.c | 6 +- generic/tclEvent.c | 9 +-- generic/tclFCmd.c | 139 +++++++++++++++++++++++--------------------- generic/tclIndexObj.c | 87 ++++++++++++++------------- generic/tclParse.c | 4 +- generic/tclPathObj.c | 16 +++-- generic/tclRegexp.c | 4 +- generic/tclResult.c | 43 +++++++------- generic/tclTimer.c | 9 +-- generic/tclTomMathStubLib.c | 8 +-- generic/tclTrace.c | 5 +- tests/fileSystem.test | 2 +- tests/string.test | 4 +- 18 files changed, 294 insertions(+), 260 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 444e7fa..a1e836e 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -873,9 +873,9 @@ BinaryFormatCmd( if (count == BINARY_ALL) { count = listc; } else if (count > listc) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "number of elements in list does not match count", - NULL); + -1)); return TCL_ERROR; } } @@ -884,9 +884,8 @@ BinaryFormatCmd( case 'x': if (count == BINARY_ALL) { - Tcl_AppendResult(interp, - "cannot use \"*\" in format string with \"x\"", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot use \"*\" in format string with \"x\"", -1)); return TCL_ERROR; } else if (count == BINARY_NOCOUNT) { count = 1; @@ -1198,8 +1197,9 @@ BinaryFormatCmd( badValue: Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected ", errorString, - " string but got \"", errorValue, "\" instead", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected %s string but got \"%s\" instead", + errorString, errorValue)); return TCL_ERROR; badCount: @@ -1217,12 +1217,13 @@ BinaryFormatCmd( Tcl_UtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad field specifier \"%s\"", buf)); return TCL_ERROR; } error: - Tcl_AppendResult(interp, errorString, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); return TCL_ERROR; } @@ -1586,12 +1587,13 @@ BinaryScanCmd( Tcl_UtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad field specifier \"%s\"", buf)); return TCL_ERROR; } error: - Tcl_AppendResult(interp, errorString, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); return TCL_ERROR; } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 5b5a0d6..6443975 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -815,15 +815,16 @@ MemoryCmd( size_t len; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option [args..]\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s option [args..]\"", argv[0])); return TCL_ERROR; } - if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { + if (strcmp(argv[1], "active") == 0 || strcmp(argv[1], "display") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " file\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s file\"", + argv[0], argv[1])); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -833,7 +834,8 @@ MemoryCmd( result = Tcl_DumpActiveMemory(fileName); Tcl_DStringFree(&buffer); if (result != TCL_OK) { - Tcl_AppendResult(interp, "error accessing ", argv[2], NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s", + argv[2], Tcl_PosixError(interp))); return TCL_ERROR; } return TCL_OK; @@ -857,17 +859,17 @@ MemoryCmd( "maximum bytes allocated", (unsigned long)maximum_bytes_malloced)); return TCL_OK; } - if (strcmp(argv[1],"init") == 0) { + if (strcmp(argv[1], "init") == 0) { if (argc != 3) { goto bad_suboption; } init_malloced_bodies = (strcmp(argv[2],"on") == 0); return TCL_OK; } - if (strcmp(argv[1],"objs") == 0) { + if (strcmp(argv[1], "objs") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " objs file\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s objs file\"", argv[0])); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -876,7 +878,9 @@ MemoryCmd( } fileP = fopen(fileName, "w"); if (fileP == NULL) { - Tcl_AppendResult(interp, "cannot open output file", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot open output file: %s", + Tcl_PosixError(interp))); return TCL_ERROR; } TclDbDumpActiveObjects(fileP); @@ -886,8 +890,8 @@ MemoryCmd( } if (strcmp(argv[1],"onexit") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " onexit file\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s onexit file\"", argv[0])); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -901,8 +905,8 @@ MemoryCmd( } if (strcmp(argv[1],"tag") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " tag string\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s tag string\"", argv[0])); return TCL_ERROR; } if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { @@ -939,19 +943,20 @@ MemoryCmd( return TCL_OK; } - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be active, break_on_malloc, info, init, objs, onexit, " - "tag, trace, trace_on_at_malloc, or validate", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": should be active, break_on_malloc, info, " + "init, objs, onexit, tag, trace, trace_on_at_malloc, or validate", + argv[1])); return TCL_ERROR; argError: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " count\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s count\"", argv[0], argv[1])); return TCL_ERROR; bad_suboption: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " on|off\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s on|off\"", argv[0], argv[1])); return TCL_ERROR; } @@ -981,8 +986,8 @@ CheckmemCmd( const char *argv[]) /* String values of arguments. */ { if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " fileName\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s fileName\"", argv[0])); return TCL_ERROR; } tclMemDumpFileName = dumpFile; diff --git a/generic/tclClock.c b/generic/tclClock.c index e46ac69..6d2976d 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1018,17 +1018,17 @@ ConvertUTCToLocalUsingC( tock = (time_t) fields->seconds; if ((Tcl_WideInt) tock != fields->seconds) { - Tcl_AppendResult(interp, - "number too large to represent as a Posix time", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "number too large to represent as a Posix time", -1)); Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL); return TCL_ERROR; } TzsetIfNecessary(); timeVal = ThreadSafeLocalTime(&tock); if (timeVal == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "localtime failed (clock value may be too " - "large/small to represent)", NULL); + "large/small to represent)", -1)); Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL); return TCL_ERROR; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 4bb993e..5ca5cf8 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -194,7 +194,8 @@ Tcl_CaseObjCmd( if (i == caseObjc-1) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "extra case pattern with no body", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra case pattern with no body", -1)); return TCL_ERROR; } @@ -409,8 +410,9 @@ Tcl_CdObjCmd( } else { result = Tcl_FSChdir(dir); if (result != TCL_OK) { - Tcl_AppendResult(interp, "couldn't change working directory to \"", - TclGetString(dir), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't change working directory to \"%s\": %s", + TclGetString(dir), Tcl_PosixError(interp))); result = TCL_ERROR; } } @@ -642,8 +644,9 @@ EncodingDirsObjCmd( dirListObj = objv[2]; if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) { - Tcl_AppendResult(interp, "expected directory list but got \"", - TclGetString(dirListObj), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected directory list but got \"%s\"", + TclGetString(dirListObj))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH", NULL); return TCL_ERROR; @@ -1165,9 +1168,9 @@ FileAttrAccessTimeCmd( tval.modtime = buf.st_mtime; if (Tcl_FSUtime(objv[1], &tval) != 0) { - Tcl_AppendResult(interp, "could not set access time for file \"", - TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set access time for file \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1237,9 +1240,9 @@ FileAttrModifyTimeCmd( tval.modtime = newTime; if (Tcl_FSUtime(objv[1], &tval) != 0) { - Tcl_AppendResult(interp, "could not set modification time for " - "file \"", TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set modification time for file \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1990,8 +1993,9 @@ PathSplitCmd( } res = Tcl_FSSplitPath(objv[1], NULL); if (res == NULL) { - Tcl_AppendResult(interp, "could not read \"", TclGetString(objv[1]), - "\": no such file or directory", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": no such file or directory", + TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH", NULL); return TCL_ERROR; @@ -2212,9 +2216,9 @@ GetStatBuf( if (status < 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2649,7 +2653,8 @@ TclNRForeachCmd( TclListObjGetElements(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { - Tcl_AppendResult(interp, "foreach varlist is empty", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "foreach varlist is empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FOREACH", "NEEDVARS", NULL); result = TCL_ERROR; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7e94d9f..9e720ea 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -204,8 +204,8 @@ Tcl_RegexpObjCmd( */ if (doinline && ((objc - 2) != 0)) { - Tcl_AppendResult(interp, "regexp match variables not allowed" - " when using -inline", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "regexp match variables not allowed when using -inline", -1)); goto optionError; } @@ -1839,8 +1839,8 @@ StringMapCmd( strncmp(string, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { - Tcl_AppendResult(interp, "bad option \"", string, - "\": must be -nocase", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string, NULL); return TCL_ERROR; @@ -2106,8 +2106,8 @@ StringMatchCmd( strncmp(string, "-nocase", (size_t) length) == 0) { nocase = TCL_MATCH_NOCASE; } else { - Tcl_AppendResult(interp, "bad option \"", string, - "\": must be -nocase", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string, NULL); return TCL_ERROR; @@ -2567,8 +2567,9 @@ StringEqualCmd( return TCL_ERROR; } } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -nocase or -length", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase or -length", + string2)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string2, NULL); return TCL_ERROR; @@ -2716,8 +2717,9 @@ StringCmpCmd( return TCL_ERROR; } } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -nocase or -length", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase or -length", + string2)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string2, NULL); return TCL_ERROR; @@ -3515,9 +3517,9 @@ TclNRSwitchObjCmd( * Mode already set via -exact, -glob, or -regexp. */ - Tcl_AppendResult(interp, "bad option \"", - TclGetString(objv[i]), "\": ", options[mode], - " option already found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": %s option already found", + TclGetString(objv[i]), options[mode])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "DOUBLEOPT", NULL); return TCL_ERROR; @@ -3534,8 +3536,9 @@ TclNRSwitchObjCmd( case OPT_INDEXV: i++; if (i >= objc-2) { - Tcl_AppendResult(interp, "missing variable name argument to ", - "-indexvar", " option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing variable name argument to %s option", + "-indexvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "NOVAR", NULL); return TCL_ERROR; @@ -3546,8 +3549,9 @@ TclNRSwitchObjCmd( case OPT_MATCHV: i++; if (i >= objc-2) { - Tcl_AppendResult(interp, "missing variable name argument to ", - "-matchvar", " option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing variable name argument to %s option", + "-matchvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "NOVAR", NULL); return TCL_ERROR; @@ -3565,15 +3569,15 @@ TclNRSwitchObjCmd( return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { - Tcl_AppendResult(interp, - "-indexvar option requires -regexp option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s option requires -regexp option", "-indexvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "MODERESTRICTION", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { - Tcl_AppendResult(interp, - "-matchvar option requires -regexp option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s option requires -regexp option", "-matchvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "MODERESTRICTION", NULL); return TCL_ERROR; @@ -3622,7 +3626,8 @@ TclNRSwitchObjCmd( if (objc % 2) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra switch pattern with no body", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", NULL); @@ -3637,10 +3642,10 @@ TclNRSwitchObjCmd( if (splitObjs) { for (i=0 ; i objc-4) { - Tcl_AppendResult(interp, "wrong # args to on clause: ", - "must be \"", TclGetString(objv[0]), - " ... on code variableList script\"", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to on clause: must be \"... on code" + " variableList script\"", -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", "ARGUMENT", NULL); return TCL_ERROR; } - if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) { + if (TclGetCompletionCodeFromObj(interp, objv[i+1], + &code) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } @@ -4205,9 +4213,10 @@ TclNRTryObjCmd( case TryTrap: /* trap pattern variableList script */ if (i > objc-4) { - Tcl_AppendResult(interp, "wrong # args to trap clause: ", + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to trap clause: " "must be \"... trap pattern variableList script\"", - NULL); + -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", "ARGUMENT", NULL); @@ -4248,9 +4257,8 @@ TclNRTryObjCmd( } } if (bodyShared) { - Tcl_AppendResult(interp, - "last non-finally clause must not have a body of \"-\"", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "last non-finally clause must not have a body of \"-\"", -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", NULL); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 0fa6661..7a55724 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1542,7 +1542,8 @@ OpenEncodingFileChannel( } if ((NULL == chan) && (interp != NULL)) { - Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown encoding \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); } Tcl_DecrRefCount(fileNameObj); @@ -1616,7 +1617,8 @@ LoadEncodingFile( break; } if ((encoding == NULL) && (interp != NULL)) { - Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid encoding file \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); } Tcl_Close(NULL, chan); diff --git a/generic/tclEvent.c b/generic/tclEvent.c index e65862c..0b585b6 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1416,7 +1416,7 @@ Tcl_VwaitObjCmd( } if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); break; } } @@ -1426,8 +1426,9 @@ Tcl_VwaitObjCmd( if (!foundEvent) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't wait for variable \"", nameString, - "\": would wait forever", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't wait for variable \"%s\": would wait forever", + nameString)); Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL); return TCL_ERROR; } @@ -1519,7 +1520,7 @@ Tcl_UpdateObjCmd( } if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); return TCL_ERROR; } } diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index a868fe3..032dda7 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -152,9 +152,9 @@ FileCopyRename( if ((objc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); - Tcl_AppendResult(interp, "error ", - (copyFlag ? "copying" : "renaming"), ": target \"", - TclGetString(target), "\" is not a directory", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error %s: target \"%s\" is not a directory", + (copyFlag?"copying":"renaming"), TclGetString(target))); result = TCL_ERROR; } else { /* @@ -304,8 +304,9 @@ TclFileMakeDirsCmd( done: if (errfile != NULL) { - Tcl_AppendResult(interp, "can't create directory \"", - TclGetString(errfile), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create directory \"%s\": %s", + TclGetString(errfile), Tcl_PosixError(interp))); result = TCL_ERROR; } if (split != NULL) { @@ -384,9 +385,9 @@ TclFileDeleteCmd( result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer); if (result != TCL_OK) { if ((force == 0) && (errno == EEXIST)) { - Tcl_AppendResult(interp, "error deleting \"", - TclGetString(objv[i]), "\": directory not empty", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error deleting \"%s\": directory not empty", + TclGetString(objv[i]))); Tcl_PosixError(interp); goto done; } @@ -426,12 +427,13 @@ TclFileDeleteCmd( * We try to accomodate poor error results from our Tcl_FS calls. */ - Tcl_AppendResult(interp, "error deleting unknown file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error deleting unknown file: %s", + Tcl_PosixError(interp))); } else { - Tcl_AppendResult(interp, "error deleting \"", - TclGetString(errfile), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error deleting \"%s\": %s", + TclGetString(errfile), Tcl_PosixError(interp))); } } @@ -540,17 +542,17 @@ CopyRenameOneFile( if (S_ISDIR(sourceStatBuf.st_mode) && !S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite file \"", - TclGetString(target), "\" with directory \"", - TclGetString(source), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't overwrite file \"%s\" with directory \"%s\"", + TclGetString(target), TclGetString(source))); goto done; } if (!S_ISDIR(sourceStatBuf.st_mode) && S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite directory \"", - TclGetString(target), "\" with file \"", - TclGetString(source), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't overwrite directory \"%s\" with file \"%s\"", + TclGetString(target), TclGetString(source))); goto done; } @@ -581,10 +583,10 @@ CopyRenameOneFile( } if (errno == EINVAL) { - Tcl_AppendResult(interp, "error renaming \"", - TclGetString(source), "\" to \"", TclGetString(target), - "\": trying to rename a volume or " - "move a directory into itself", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error renaming \"%s\" to \"%s\": trying to rename a" + " volume or move a directory into itself", + TclGetString(source), TclGetString(target))); goto done; } else if (errno != EXDEV) { errfile = target; @@ -628,8 +630,9 @@ CopyRenameOneFile( * Actual file doesn't exist. */ - Tcl_AppendResult(interp, "error copying \"", TclGetString(source), - "\": the target of this link doesn't exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error copying \"%s\": the target of this link doesn't" + " exist", TclGetString(source))); goto done; } else { int counter = 0; @@ -764,23 +767,27 @@ CopyRenameOneFile( } } if (result != TCL_OK) { - Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't unlink \"%s\": %s", + TclGetString(errfile), Tcl_PosixError(interp))); errfile = NULL; } } done: if (errfile != NULL) { - Tcl_AppendResult(interp, "error ", (copyFlag ? "copying" : "renaming"), - " \"", TclGetString(source), NULL); + Tcl_Obj *errorMsg = Tcl_ObjPrintf("error %s \"%s\"", + (copyFlag ? "copying" : "renaming"), TclGetString(source)); + if (errfile != source) { - Tcl_AppendResult(interp, "\" to \"", TclGetString(target), NULL); + Tcl_AppendPrintfToObj(errorMsg, " to \"%s\"", + TclGetString(target)); if (errfile != target) { - Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),NULL); + Tcl_AppendPrintfToObj(errorMsg, ": \"%s\"", + TclGetString(errfile)); } } - Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), NULL); + Tcl_AppendPrintfToObj(errorMsg, ": %s", Tcl_PosixError(interp)); + Tcl_SetObjResult(interp, errorMsg); } if (errorBuffer != NULL) { Tcl_DecrRefCount(errorBuffer); @@ -983,9 +990,10 @@ TclFileAttrsCmd( * There was an error, probably that the filePtr is not * accepted by any filesystem */ - Tcl_AppendResult(interp, "could not read \"", - TclGetString(filePtr), "\": ", Tcl_PosixError(interp), - NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(filePtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1071,9 +1079,9 @@ TclFileAttrsCmd( Tcl_Obj *objPtr = NULL; if (numObjStrings == 0) { - Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), - "\", there are no file attributes in this filesystem.", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\", there are no file attributes in this" + " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } @@ -1098,9 +1106,9 @@ TclFileAttrsCmd( int i, index; if (numObjStrings == 0) { - Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), - "\", there are no file attributes in this filesystem.", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\", there are no file attributes in this" + " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } @@ -1114,8 +1122,8 @@ TclFileAttrsCmd( TclFreeIntRep(objv[i]); } if (i + 1 == objc) { - Tcl_AppendResult(interp, "value for \"", - TclGetString(objv[i]), "\" missing", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "value for \"%s\" missing", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR", "NOVALUE", NULL); goto end; @@ -1224,9 +1232,9 @@ TclFileLinkCmd( */ if (errno == EEXIST) { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), - "\": that path already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\": that path already" + " exists", TclGetString(objv[index]))); Tcl_PosixError(interp); } else if (errno == ENOENT) { /* @@ -1244,23 +1252,23 @@ TclFileLinkCmd( access = Tcl_FSAccess(dirPtr, F_OK); Tcl_DecrRefCount(dirPtr); if (access != 0) { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), - "\": no such file or directory", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\": no such file" + " or directory", TclGetString(objv[index]))); Tcl_PosixError(interp); } else { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), "\": target \"", - TclGetString(objv[index+1]), "\" doesn't exist", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\": target \"%s\" " + "doesn't exist", TclGetString(objv[index]), + TclGetString(objv[index+1]))); errno = ENOENT; Tcl_PosixError(interp); } } else { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), "\" pointing to \"", - TclGetString(objv[index+1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\" pointing to \"%s\": %s", + TclGetString(objv[index]), + TclGetString(objv[index+1]), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1275,9 +1283,9 @@ TclFileLinkCmd( contents = Tcl_FSLink(objv[index], NULL, 0); if (contents == NULL) { - Tcl_AppendResult(interp, "could not read link \"", - TclGetString(objv[index]), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read link \"%s\": %s", + TclGetString(objv[index]), Tcl_PosixError(interp))); return TCL_ERROR; } } @@ -1332,8 +1340,9 @@ TclFileReadLinkCmd( contents = Tcl_FSLink(objv[1], NULL, 0); if (contents == NULL) { - Tcl_AppendResult(interp, "could not readlink \"", - TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read link \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } Tcl_SetObjResult(interp, contents); @@ -1487,8 +1496,8 @@ TclFileTemporaryCmd( if (nameVarObj) { TclDecrRefCount(nameObj); } - Tcl_AppendResult(interp, "can't create temporary file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create temporary file: %s", Tcl_PosixError(interp))); return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); @@ -1499,7 +1508,7 @@ TclFileTemporaryCmd( return TCL_ERROR; } } - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 85e0730..731d759 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -600,8 +600,9 @@ PrefixMatchObjCmd( flags |= TCL_EXACT; break; case PRFMATCH_MESSAGE: - if (i > (objc - 4)) { - Tcl_AppendResult(interp, "missing message", NULL); + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing value for -message", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); return TCL_ERROR; } @@ -610,7 +611,8 @@ PrefixMatchObjCmd( break; case PRFMATCH_ERROR: if (i > objc-4) { - Tcl_AppendResult(interp, "missing error options", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing value for -error", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); return TCL_ERROR; } @@ -620,8 +622,9 @@ PrefixMatchObjCmd( return TCL_ERROR; } if ((errorLength % 2) != 0) { - Tcl_AppendResult(interp, "error options must have an even" - " number of elements", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error options must have an even number of elements", + -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); return TCL_ERROR; } @@ -1174,8 +1177,8 @@ Tcl_ParseArgsObjv( goto gotMatch; } if (matchPtr != NULL) { - Tcl_AppendResult(interp, "ambiguous option \"", str, "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "ambiguous option \"%s\"", str)); goto error; } matchPtr = infoPtr; @@ -1187,8 +1190,8 @@ Tcl_ParseArgsObjv( */ if (remObjv == NULL) { - Tcl_AppendResult(interp, "unrecognized argument \"", str, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unrecognized argument \"%s\"", str)); goto error; } @@ -1213,9 +1216,9 @@ Tcl_ParseArgsObjv( } if (Tcl_GetIntFromObj(interp, objv[srcIndex], (int *) infoPtr->dstPtr) == TCL_ERROR) { - Tcl_AppendResult(interp, "expected integer argument for \"", - infoPtr->keyStr, "\" but got \"", - Tcl_GetString(objv[srcIndex]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer argument for \"%s\" but got \"%s\"", + infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); goto error; } srcIndex++; @@ -1246,9 +1249,9 @@ Tcl_ParseArgsObjv( } if (Tcl_GetDoubleFromObj(interp, objv[srcIndex], (double *) infoPtr->dstPtr) == TCL_ERROR) { - Tcl_AppendResult(interp, "expected floating-point argument ", - "for \"", infoPtr->keyStr, "\" but got \"", - Tcl_GetString(objv[srcIndex]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected floating-point argument for \"%s\" but got \"%s\"", + infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); goto error; } srcIndex++; @@ -1322,8 +1325,8 @@ Tcl_ParseArgsObjv( */ missingArg: - Tcl_AppendResult(interp, "\"", str, - "\" option requires an additional argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" option requires an additional argument", str)); error: if (leftovers != NULL) { ckfree(leftovers); @@ -1361,6 +1364,7 @@ PrintUsage( #define NUM_SPACES 20 static const char spaces[] = " "; char tmp[TCL_DOUBLE_SPACE]; + Tcl_Obj *msg; /* * First, compute the width of the widest option key, so that we can make @@ -1384,39 +1388,39 @@ PrintUsage( * Now add the option information, with pretty-printing. */ - Tcl_AppendResult(interp, "Command-specific options:", NULL); + msg = Tcl_NewStringObj("Command-specific options:", -1); for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) { if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) { - Tcl_AppendResult(interp, "\n", infoPtr->helpStr, NULL); + Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr); continue; } - Tcl_AppendResult(interp, "\n ", infoPtr->keyStr, ":", NULL); + Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr); numSpaces = width + 1 - strlen(infoPtr->keyStr); while (numSpaces > 0) { if (numSpaces >= NUM_SPACES) { - Tcl_AppendResult(interp, spaces, NULL); + Tcl_AppendToObj(msg, spaces, NUM_SPACES); } else { - Tcl_AppendResult(interp, spaces+NUM_SPACES-numSpaces, NULL); + Tcl_AppendToObj(msg, spaces, numSpaces); } numSpaces -= NUM_SPACES; } - Tcl_AppendResult(interp, infoPtr->helpStr, NULL); + Tcl_AppendToObj(msg, infoPtr->helpStr, -1); switch (infoPtr->type) { case TCL_ARGV_INT: - sprintf(tmp, "%d", *((int *) infoPtr->dstPtr)); - Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL); + Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d", + *((int *) infoPtr->dstPtr)); break; case TCL_ARGV_FLOAT: + Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g", + *((double *) infoPtr->dstPtr)); sprintf(tmp, "%g", *((double *) infoPtr->dstPtr)); - Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL); break; case TCL_ARGV_STRING: { - char *string; + char *string = *((char **) infoPtr->dstPtr); - string = *((char **) infoPtr->dstPtr); if (string != NULL) { - Tcl_AppendResult(interp, "\n\t\tDefault value: \"", string, - "\"", NULL); + Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: \"%s\"", + string); } break; } @@ -1424,6 +1428,7 @@ PrintUsage( break; } } + Tcl_SetObjResult(interp, msg); } /* @@ -1435,8 +1440,8 @@ PrintUsage( * * Results: * Returns TCL_ERROR if the value is an invalid completion code. - * Otherwise, returns TCL_OK, and writes the completion code to - * the pointer provided. + * Otherwise, returns TCL_OK, and writes the completion code to the + * pointer provided. * * Side effects: * None. @@ -1448,30 +1453,30 @@ int TclGetCompletionCodeFromObj( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *value, - int *code) /* Argument objects. */ + int *codePtr) /* Argument objects. */ { static const char *const returnCodes[] = { "ok", "error", "return", "break", "continue", NULL }; if ((value->typePtr != &indexType) - && (TCL_OK == TclGetIntFromObj(NULL, value, code))) { + && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } - if (TCL_OK == Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, - TCL_EXACT, code)) { + if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT, + codePtr) == TCL_OK) { return TCL_OK; } + /* * Value is not a legal completion code. */ if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad completion code \"", - TclGetString(value), - "\": must be ok, error, return, break, " - "continue, or an integer", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad completion code \"%s\": must be" + " ok, error, return, break, continue, or an integer", + TclGetString(value))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL); } return TCL_ERROR; diff --git a/generic/tclParse.c b/generic/tclParse.c index aab2fac..309e232 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1779,8 +1779,8 @@ Tcl_ParseBraces( break; case '#' : if (openBrace && TclIsSpaceProc(src[-1])) { - Tcl_AppendResult(parsePtr->interp, - ": possible unbalanced brace in comment", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp), + ": possible unbalanced brace in comment", -1); goto error; } break; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 8bae4fb..db07c0e 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1492,9 +1492,8 @@ MakePathFromNormalized( if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't find object" - "string representation", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't find object string representation", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", NULL); } @@ -2368,9 +2367,9 @@ SetFsPathFromAny( dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't find HOME environment " - "variable to expand path", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment variable to" + " expand path", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "HOMELESS", NULL); } @@ -2387,9 +2386,8 @@ SetFsPathFromAny( Tcl_DStringInit(&temp); if (TclpGetUserHome(name+1, &temp) == NULL) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", name+1, - "\" doesn't exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", name+1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", NULL); } diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 53d7153..6c1dc08 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -714,14 +714,14 @@ TclRegError( int status) /* Status code to report. */ { char buf[100]; /* ample in practice */ - char cbuf[100]; /* lots in practice */ + char cbuf[TCL_INTEGER_SPACE]; size_t n; const char *p; Tcl_ResetResult(interp); n = TclReError(status, NULL, buf, sizeof(buf)); p = (n > sizeof(buf)) ? "..." : ""; - Tcl_AppendResult(interp, msg, buf, p, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p)); sprintf(cbuf, "%d", status); (void) TclReError(REG_ITOA, NULL, cbuf, sizeof(cbuf)); diff --git a/generic/tclResult.c b/generic/tclResult.c index 4443cc1..17aac74 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1390,10 +1390,9 @@ TclMergeReturnOptions( * Value is not a legal dictionary. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad ", compare, - " value: expected dictionary but got \"", - TclGetString(objv[1]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad %s value: expected dictionary but got \"%s\"", + compare, TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL); goto error; @@ -1440,10 +1439,9 @@ TclMergeReturnOptions( * Value is not a legal level. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -level value: " - "expected non-negative integer but got \"", - TclGetString(valuePtr), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -level value: expected non-negative integer but got" + " \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL); goto error; } @@ -1462,10 +1460,10 @@ TclMergeReturnOptions( /* * Value is not a list, which is illegal for -errorcode. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -errorcode value: " - "expected a list but got \"", - TclGetString(valuePtr), "\"", NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -errorcode value: expected a list but got \"%s\"", + TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE", NULL); goto error; @@ -1484,10 +1482,10 @@ TclMergeReturnOptions( /* * Value is not a list, which is illegal for -errorstack. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -errorstack value: " - "expected a list but got \"", TclGetString(valuePtr), - "\"", NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -errorstack value: expected a list but got \"%s\"", + TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", NULL); goto error; @@ -1496,10 +1494,10 @@ TclMergeReturnOptions( /* * Errorstack must always be an even-sized list */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "forbidden odd-sized list for -errorstack: \"", - TclGetString(valuePtr), "\"", NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "forbidden odd-sized list for -errorstack: \"%s\"", + TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ODDSIZEDLIST_ERRORSTACK", NULL); goto error; @@ -1650,9 +1648,8 @@ Tcl_SetReturnOptions( Tcl_IncrRefCount(options); if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv) || (objc % 2)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected dict but got \"", - TclGetString(options), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected dict but got \"%s\"", TclGetString(options))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL); code = TCL_ERROR; } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv, diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 36adaad..6b17825 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -829,8 +829,9 @@ Tcl_AfterObjCmd( if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { const char *arg = Tcl_GetString(objv[1]); - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": must be cancel, idle, info, or an integer", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad argument \"%s\": must be" + " cancel, idle, info, or an integer", arg)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", arg, NULL); return TCL_ERROR; @@ -968,8 +969,8 @@ Tcl_AfterObjCmd( if (afterPtr == NULL) { const char *eventStr = TclGetString(objv[2]); - Tcl_AppendResult(interp, "event \"", eventStr, "\" doesn't exist", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "event \"%s\" doesn't exist", eventStr)); Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); return TCL_ERROR; } else { diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c index e7e4aea..a3bc4b3 100644 --- a/generic/tclTomMathStubLib.c +++ b/generic/tclTomMathStubLib.c @@ -73,10 +73,10 @@ TclTomMathInitializeStubs( tclTomMathStubsPtr = stubsPtr; return actualVersion; } - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error loading ", packageName, - " (requested version ", version, ", actual version ", - actualVersion, "): ", errMsg, NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error loading %s (requested version %s, actual version %s): %s", + packageName, version, actualVersion, errMsg)); return NULL; } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 3888549..519f201 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -366,8 +366,9 @@ Tcl_TraceObjCmd( return TCL_OK; badVarOps: - Tcl_AppendResult(interp, "bad operations \"", flagOps, - "\": should be one or more of rwua", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad operations \"%s\": should be one or more of rwua", + flagOps)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL); return TCL_ERROR; } diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 9469af0..38ecbee 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -484,7 +484,7 @@ test filesystem-6.22 {empty file name} {file pathtype ""} relative test filesystem-6.23 {empty file name} {file readable ""} 0 test filesystem-6.24 {empty file name} -returnCodes error -body { file readlink "" -} -result {could not readlink "": no such file or directory} +} -result {could not read link "": no such file or directory} test filesystem-6.25 {empty file name} -returnCodes error -body { file rename "" "" } -result {error renaming "": no such file or directory} diff --git a/tests/string.test b/tests/string.test index 8cacd07..e86c0de 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1776,10 +1776,10 @@ test string-26.3.1 {tcl::prefix, bad args} -body { } -returnCodes 1 -result {error options must have an even number of elements} test string-26.3.2 {tcl::prefix, bad args} -body { tcl::prefix match -error str1 str2 -} -returnCodes 1 -result {missing error options} +} -returnCodes 1 -result {missing value for -error} test string-26.4 {tcl::prefix, bad args} -body { tcl::prefix match -message str1 str2 -} -returnCodes 1 -result {missing message} +} -returnCodes 1 -result {missing value for -message} test string-26.5 {tcl::prefix} { tcl::prefix match {apa bepa cepa depa} cepa } cepa -- cgit v0.12 -- cgit v0.12 From 8c5e0f4fee6b9a2fc04eba8af7461c422bf0f73a Mon Sep 17 00:00:00 2001 From: twylite Date: Fri, 3 Aug 2012 16:39:49 +0000 Subject: [Patch-3163961] Implementation of TIP #405 merged from private branch. Includes 'mapeach', 'dict map' and 'foreacha' commands, test suite (partial for 'foreacha') and man pages (except for 'foreacha'). --- doc/dict.n | 22 ++- doc/mapeach.n | 91 ++++++++++ generic/tcl.h | 1 + generic/tclBasic.c | 4 +- generic/tclCmdAH.c | 110 +++++++++-- generic/tclCompCmds.c | 197 +++++++++++++++++++- generic/tclCompile.h | 1 + generic/tclDictObj.c | 67 +++++-- generic/tclExecute.c | 17 +- generic/tclInt.h | 30 +++ tests/dict.test | 246 +++++++++++++++++++++++++ tests/foreach.test | 9 + tests/foreacha.test | 217 ++++++++++++++++++++++ tests/mapeach.test | 493 ++++++++++++++++++++++++++++++++++++++++++++++++++ 14 files changed, 1466 insertions(+), 39 deletions(-) create mode 100644 doc/mapeach.n create mode 100644 tests/foreacha.test create mode 100644 tests/mapeach.test diff --git a/doc/dict.n b/doc/dict.n index 361a112..b9b4767 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -147,6 +147,24 @@ keys are treated as if they map to an empty list, and it is legal for there to be no items to append to the list. It is an error for the value that the key maps to to not be representable as a list. .TP +\fBdict map {\fIkeyVar valueVar\fB} \fIdictionaryValue body\fR +. +This command takes three arguments, the first a two-element list of +variable names (for the key and value respectively of each mapping in +the dictionary), the second the dictionary value to iterate across, +and the third a script to be evaluated for each mapping with the key +and value variables set appropriately (in the manner of \fBmapeach\fR.) +In an iteration where the evaluated script completes normally +(\fBTCL_OK\fR) the script result is appended to an accumulator list. +The result of the \fBdict map\fB command is the accumulator list. +If any evaluation of the body generates a \fBTCL_BREAK\fR result, no +further pairs from the dictionary will be iterated over and the +\fBdict map\fR command will terminate successfully immediately. If any +evaluation of the body generates a \fBTCL_CONTINUE\fR result, the +current iteration is aborted and the accumulator list is not modified. +The order of iteration is the order in which the keys were inserted into +the dictionary. +.TP \fBdict merge \fR?\fIdictionaryValue ...\fR? . Return a dictionary that contains the contents of each of the @@ -408,9 +426,9 @@ puts $foo # prints: \fIa b foo {a b} bar 2 baz 3\fR .CE .SH "SEE ALSO" -append(n), array(n), foreach(n), incr(n), list(n), lappend(n), set(n) +append(n), array(n), foreach(n), mapeach(n), incr(n), list(n), lappend(n), set(n) .SH KEYWORDS -dictionary, create, update, lookup, iterate, filter +dictionary, create, update, lookup, iterate, filter, map '\" Local Variables: '\" mode: nroff '\" End: diff --git a/doc/mapeach.n b/doc/mapeach.n new file mode 100644 index 0000000..c89f7d9 --- /dev/null +++ b/doc/mapeach.n @@ -0,0 +1,91 @@ +'\" +'\" Copyright (c) 2012 Trevor Davel +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.so man.macros +.TH mapeach n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +mapeach \- Iterate over all elements in one or more lists and collect results +.SH SYNOPSIS +\fBmapeach \fIvarname list body\fR +.br +\fBmapeach \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR +.BE + +.SH DESCRIPTION +.PP +The \fBmapeach\fR command implements a loop where the loop +variable(s) take on values from one or more lists, and the loop returns a list +of results collected from each iteration. +.PP +In the simplest case there is one loop variable, \fIvarname\fR, +and one list, \fIlist\fR, that is a list of values to assign to \fIvarname\fR. +The \fIbody\fR argument is a Tcl script. +For each element of \fIlist\fR (in order +from first to last), \fBmapeach\fR assigns the contents of the +element to \fIvarname\fR as if the \fBlindex\fR command had been used +to extract the element, then calls the Tcl interpreter to execute +\fIbody\fR. If execution of the body completes normally then the result of the +body is appended to an accumulator list. \fBmapeach\fR returns the accumulator +list. + +.PP +In the general case there can be more than one value list +(e.g., \fIlist1\fR and \fIlist2\fR), +and each value list can be associated with a list of loop variables +(e.g., \fIvarlist1\fR and \fIvarlist2\fR). +During each iteration of the loop +the variables of each \fIvarlist\fR are assigned +consecutive values from the corresponding \fIlist\fR. +Values in each \fIlist\fR are used in order from first to last, +and each value is used exactly once. +The total number of loop iterations is large enough to use +up all the values from all the value lists. +If a value list does not contain enough +elements for each of its loop variables in each iteration, +empty values are used for the missing elements. +.PP +The \fBbreak\fR and \fBcontinue\fR statements may be +invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR +and \fBforeach\fR commands. In these cases the body does not complete normally +and the result is not appended to the accumulator list. +.SH EXAMPLES +.PP +Zip lists together: +.PP +.CS +'\" Maintainers: notice the tab hacking below! +.ta 3i +set list1 {a b c d} +set list2 {1 2 3 4} +set zipped [\fBmapeach\fR a $list1 b $list2 {list $a $b}] +# The value of zipped is "{a 1} {b 2} {c 3} {d 4}" +.CE +.PP +Filter a list: +.PP +.CS +set values {1 2 3 4 5 6 7 8} +proc isGood {n} { expr { ($n % 2) == 0 } } +set goodOnes [\fBmapeach\fR x $values {expr {[isGood $x] ? $x : [continue]}}] +# The value of goodOnes is "2 4 6 8" +.CE +.PP +Take a prefix from a list: +.PP +.CS +set values {8 7 6 5 4 3 2 1} +proc isGood {n} { expr { $n > 3 } } +set prefix [\fBmapeach\fR x $values {expr {[isGood $x] ? $x : [break]}}] +# The value of prefix is "8 7 6 5 4" +.CE + +.SH "SEE ALSO" +for(n), while(n), break(n), continue(n), foreach(n) + +.SH KEYWORDS +foreach, iteration, list, loop, map diff --git a/generic/tcl.h b/generic/tcl.h index 729e521..9a7c224 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1359,6 +1359,7 @@ typedef struct { int epoch; /* Epoch marker for dictionary being searched, * or -1 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ + Tcl_Obj *resultList; /* List of result values from the loop body. */ } Tcl_DictSearch; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 537750e..fe8fa5a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -219,6 +219,7 @@ static const CmdInfo builtInCmds[] = { {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, + {"foreacha", Tcl_ForeachaObjCmd, TclCompileForeachaCmd, TclNRForeachaCmd, 1}, {"format", Tcl_FormatObjCmd, NULL, NULL, 1}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, @@ -237,6 +238,7 @@ static const CmdInfo builtInCmds[] = { {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, + {"mapeach", Tcl_MapeachObjCmd, TclCompileMapeachCmd, TclNRMapeachCmd, 1}, {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, @@ -8849,7 +8851,7 @@ NRCoroInjectObjCmd( return TCL_OK; } - + int TclNRInterpCoroutine( ClientData clientData, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f09ee70..333946a 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -32,6 +32,7 @@ struct ForeachState { int *argcList; /* Array of value list sizes. */ Tcl_Obj ***argvList; /* Array of value lists. */ Tcl_Obj **aCopyList; /* Copies of value list arguments. */ + Tcl_Obj *resultList; /* List of result values from the loop body. */ }; /* @@ -44,7 +45,7 @@ static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static inline int ForeachAssignments(Tcl_Interp *interp, - struct ForeachState *statePtr); + struct ForeachState *statePtr, int collect); static inline void ForeachCleanup(Tcl_Interp *interp, struct ForeachState *statePtr); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -52,6 +53,8 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); +static int TclNREachloopCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[], int collect); static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ExprCallback; static Tcl_NRPostProc ForSetupCallback; @@ -2560,7 +2563,7 @@ ForPostNextCallback( /* *---------------------------------------------------------------------- * - * Tcl_ForeachObjCmd, TclNRForeachCmd -- + * Tcl_ForeachObjCmd, TclNRForeachCmd, TclNREachloopCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl * command. See the user documentation for details on what it does. @@ -2592,6 +2595,58 @@ TclNRForeachCmd( int objc, Tcl_Obj *const objv[]) { + return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_KEEP_NONE); +} + +int +Tcl_MapeachObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRMapeachCmd, dummy, objc, objv); +} + +int +TclNRMapeachCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_COLLECT); +} + +int +Tcl_ForeachaObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRForeachaCmd, dummy, objc, objv); +} + +int +TclNRForeachaCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_ACCUM); +} + +int +TclNREachloopCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[], + int collect) /* Select collecting or accumulating mode (TCL_EACH_*) */ +{ + int numLists = (objc-2) / 2; register struct ForeachState *statePtr; int i, j, result; @@ -2635,6 +2690,8 @@ TclNRForeachCmd( statePtr->bodyPtr = objv[objc - 1]; statePtr->bodyIdx = objc - 1; + statePtr->resultList = Tcl_NewListObj(0, NULL); + /* * Break up the value lists and variable lists into elements. */ @@ -2663,9 +2720,13 @@ TclNRForeachCmd( TclListObjGetElements(NULL, statePtr->aCopyList[i], &statePtr->argcList[i], &statePtr->argvList[i]); - j = statePtr->argcList[i] / statePtr->varcList[i]; - if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { - j++; + j = (i == 0) && (collect == TCL_EACH_ACCUM); /* Accumulator present? */ + /* If accumulator is only var in list, then we iterate j=1 times */ + if (statePtr->varcList[i] > j) { + /* We need listLen/numVars round up = ((listLen+numVars-1)/numVars) + * When accum is present we need (listLen-1)/(numVars-1) round up */ + j = (statePtr->argcList[i] - j + statePtr->varcList[i] - j - 1) + / (statePtr->varcList[i] - j); } if (j > statePtr->maxj) { statePtr->maxj = j; @@ -2678,12 +2739,12 @@ TclNRForeachCmd( */ if (statePtr->maxj > 0) { - result = ForeachAssignments(interp, statePtr); + result = ForeachAssignments(interp, statePtr, collect); if (result == TCL_ERROR) { goto done; } - TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL); + TclNRAddCallback(interp, ForeachLoopStep, statePtr, collect, NULL, NULL); return TclNREvalObjEx(interp, objv[objc-1], 0, ((Interp *) interp)->cmdFramePtr, objc-1); } @@ -2710,6 +2771,7 @@ ForeachLoopStep( int result) { register struct ForeachState *statePtr = data[0]; + int collect = (int)data[1]; /* Selected collecting or accumulating mode. */ /* * Process the result code from this run of the [foreach] body. Note that @@ -2719,11 +2781,15 @@ ForeachLoopStep( switch (result) { case TCL_CONTINUE: result = TCL_OK; + break; case TCL_OK: + if (collect == TCL_EACH_COLLECT) { + Tcl_ListObjAppendElement(interp, statePtr->resultList, Tcl_GetObjResult(interp)); + } break; case TCL_BREAK: result = TCL_OK; - goto done; + goto finish; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"foreach\" body line %d)", Tcl_GetErrorLine(interp))); @@ -2737,12 +2803,12 @@ ForeachLoopStep( */ if (statePtr->maxj > ++statePtr->j) { - result = ForeachAssignments(interp, statePtr); + result = ForeachAssignments(interp, statePtr, collect); if (result == TCL_ERROR) { goto done; } - TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL); + TclNRAddCallback(interp, ForeachLoopStep, statePtr, collect, NULL, NULL); return TclNREvalObjEx(interp, statePtr->bodyPtr, 0, ((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx); } @@ -2750,8 +2816,18 @@ ForeachLoopStep( /* * We're done. Tidy up our work space and finish off. */ - - Tcl_ResetResult(interp); +finish: + if (collect == TCL_EACH_ACCUM) { + Tcl_Obj* valueObj = Tcl_ObjGetVar2(interp, statePtr->varvList[0][0], + NULL, TCL_LEAVE_ERR_MSG); + if (valueObj == NULL) { + goto done; + } + Tcl_SetObjResult(interp, valueObj); + } else { + Tcl_SetObjResult(interp, statePtr->resultList); + statePtr->resultList = NULL; /* Don't clean it up */ + } done: ForeachCleanup(interp, statePtr); return result; @@ -2764,13 +2840,16 @@ ForeachLoopStep( static inline int ForeachAssignments( Tcl_Interp *interp, - struct ForeachState *statePtr) + struct ForeachState *statePtr, + int collect) /* Select collecting or accumulating mode (TCL_EACH_*) */ { int i, v, k; Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; inumLists ; i++) { - for (v=0 ; vvarcList[i] ; v++) { + /* Don't modify the accumulator except on the first iteration */ + v = ((i == 0) && (collect == TCL_EACH_ACCUM) && (statePtr->index[i] > 0)); + for (; vvarcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { @@ -2813,6 +2892,9 @@ ForeachCleanup( TclDecrRefCount(statePtr->aCopyList[i]); } } + if (statePtr->resultList) { + TclDecrRefCount(statePtr->resultList); + } TclStackFree(interp, statePtr); } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3540716..07a5eea 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -40,6 +40,13 @@ static int PushVarName(Tcl_Interp *interp, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, int line, int *clNext); +static int TclCompileEachloopCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, + int collect); +static int TclCompileDictEachCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr, int collect); + /* * Macro that encapsulates an efficiency trick that avoids a function call for @@ -586,6 +593,7 @@ TclCompileContinueCmd( * dict incr * dict keys [*] * dict lappend + * dict map * dict set * dict unset * @@ -787,11 +795,37 @@ TclCompileDictForCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + return TclCompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, 0); +} + +int +TclCompileDictMapCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return TclCompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, 1); +} + +int +TclCompileDictEachCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int collect) /* Flag == 1 to collect and return loop body result. */ +{ DefineLineInformation; /* TIP #280 */ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; int numVars, endTargetOffset; + int collectTemp; /* Index of temp var holding the result list. */ int savedStackDepth = envPtr->currStackDepth; /* Needed because jumps confuse the stack * space calculator. */ @@ -864,6 +898,22 @@ TclCompileDictForCmd( } /* + * Create temporary variable to capture return values from loop body. + */ + + if (collect == 1) { + collectTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, envPtr); + + PushLiteral(envPtr, "", 0); + if (collectTemp <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, collectTemp, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + + /* * Preparation complete; issue instructions. Note that this code issues * fixed-sized jumps. That simplifies things a lot! * @@ -908,6 +958,13 @@ TclCompileDictForCmd( SetLineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); + if (collect == 1) { + if (collectTemp <= 255) { + TclEmitInstInt1(INST_LAPPEND_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_SCALAR4, collectTemp, envPtr); + } + } TclEmitOpcode( INST_POP, envPtr); /* @@ -975,14 +1032,22 @@ TclCompileDictForCmd( /* * Final stage of the command (normal case) is that we push an empty - * object. This is done last to promote peephole optimization when it's - * dropped immediately. + * object (or push the accumulator as the result object). This is done + * last to promote peephole optimization when it's dropped immediately. */ jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, envPtr->codeStart + endTargetOffset); - PushLiteral(envPtr, "", 0); + if (collect == 1) { + if (collectTemp <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, collectTemp, envPtr); + } + } else { + PushLiteral(envPtr, "", 0); + } return TCL_OK; } @@ -1846,9 +1911,9 @@ TclCompileForCmd( /* *---------------------------------------------------------------------- * - * TclCompileForeachCmd -- + * TclCompileForeachCmd, TclCompileForeachaCmd -- * - * Procedure called to compile the "foreach" command. + * Procedure called to compile the "foreach" and "foreacha" commands. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer @@ -1870,6 +1935,49 @@ TclCompileForeachCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 0); +} + +int +TclCompileForeachaCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 2); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileEachloopCmd -- + * + * Procedure called to compile the "foreach" and "mapeach" commands. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "foreach" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +static int +TclCompileEachloopCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int collect) /* Select collecting or accumulating mode (TCL_EACH_*) */ +{ Proc *procPtr = envPtr->procPtr; ForeachInfo *infoPtr; /* Points to the structure describing this * foreach command. Stored in a AuxData @@ -1878,6 +1986,8 @@ TclCompileForeachCmd( * used to point to a value list. */ int loopCtTemp; /* Index of temp var holding the loop's * iteration count. */ + int collectTemp = -1; /* Index of temp var holding the result var index. */ + Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; @@ -2026,6 +2136,7 @@ TclCompileForeachCmd( infoPtr->numLists = numLists; infoPtr->firstValueTemp = firstValueTemp; infoPtr->loopCtTemp = loopCtTemp; + infoPtr->collect = collect; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; @@ -2039,6 +2150,9 @@ TclCompileForeachCmd( varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, nameChars, /*create*/ 1, envPtr); + if ((collect == TCL_EACH_ACCUM) && ((loopIndex + j) == 0)) { + collectTemp = varListPtr->varIndexes[j]; + } } infoPtr->varLists[loopIndex] = varListPtr; } @@ -2069,6 +2183,22 @@ TclCompileForeachCmd( } /* + * Create temporary variable to capture return values from loop body. + */ + + if (collect == TCL_EACH_COLLECT) { + collectTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, envPtr); + + PushLiteral(envPtr, "", 0); + if (collectTemp <= 255) { + TclEmitInstInt1( INST_STORE_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4( INST_STORE_SCALAR4, collectTemp, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); + } + + /* * Initialize the temporary var that holds the count of loop iterations. */ @@ -2092,7 +2222,16 @@ TclCompileForeachCmd( CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; - TclEmitOpcode( INST_POP, envPtr); + + if (collect == TCL_EACH_COLLECT) { + if (collectTemp <= 255) { + TclEmitInstInt1( INST_LAPPEND_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4( INST_LAPPEND_SCALAR4, collectTemp, envPtr); + } + } + TclEmitOpcode( INST_POP, envPtr); + /* * Jump back to the test at the top of the loop. Generate a 4 byte jump if @@ -2142,11 +2281,20 @@ TclCompileForeachCmd( ExceptionRangeTarget(envPtr, range, breakOffset); /* - * The foreach command's result is an empty string. + * The command's result is an empty string if not collecting, or the + * list of results from evaluating the loop body. */ envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + if (collectTemp >= 0) { + if (collectTemp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, collectTemp, envPtr); + } + } else { + PushLiteral(envPtr, "", 0); + } envPtr->currStackDepth = savedStackDepth + 1; done: @@ -2196,6 +2344,7 @@ DupForeachInfo( dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; + dupPtr->collect = srcPtr->collect; for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; @@ -2286,6 +2435,8 @@ PrintForeachInfo( } Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", (unsigned) infoPtr->loopCtTemp); + Tcl_AppendPrintfToObj(appendObj, "], collect=%%v%u", + (unsigned) infoPtr->collect); for (i=0 ; inumLists ; i++) { if (i) { Tcl_AppendToObj(appendObj, ",", -1); @@ -3700,6 +3851,36 @@ TclCompileLsetCmd( /* *---------------------------------------------------------------------- * + * TclCompileMapeachCmd -- + * + * Procedure called to compile the "mapeach" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "mapeach" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileMapeachCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 1); +} + +/* + *---------------------------------------------------------------------- + * * TclCompileNamespaceCmd -- * * Procedure called to compile the "namespace" command; currently, only diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ba78c36..7a41bb1 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -807,6 +807,7 @@ typedef struct ForeachInfo { * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ + int collect; /* Selected collecting or accumulating mode. */ ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index ac2cb62..2e24d75 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -76,7 +76,11 @@ static int FinalizeDictWith(ClientData data[], Tcl_Interp *interp, int result); static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int DictForLoopCallback(ClientData data[], +static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictEachNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv, int collect); +static int DictEachLoopCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -95,6 +99,7 @@ static const EnsembleImplMap implementationMap[] = { {"info", DictInfoCmd, NULL, NULL, NULL, 0 }, {"keys", DictKeysCmd, NULL, NULL, NULL, 0 }, {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, + {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, {"merge", DictMergeCmd, NULL, NULL, NULL, 0 }, {"remove", DictRemoveCmd, NULL, NULL, NULL, 0 }, {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, @@ -2329,11 +2334,11 @@ DictAppendCmd( /* *---------------------------------------------------------------------- * - * DictForNRCmd -- + * DictForNRCmd, DictMapNRCmd, DictEachNRCmd -- * - * This function implements the "dict for" Tcl command. See the user - * documentation for details on what it does, and TIP#111 for the formal - * specification. + * These functions implement the "dict for" and "dict map" Tcl commands. + * See the user documentation for details on what it does, and TIP#111 + * and TIP#405 for the formal specification. * * Results: * A standard Tcl result. @@ -2351,6 +2356,27 @@ DictForNRCmd( int objc, Tcl_Obj *const *objv) { + return DictEachNRCmd(dummy, interp, objc, objv, 0); +} + +static int +DictMapNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return DictEachNRCmd(dummy, interp, objc, objv, 1); +} + +static int +DictEachNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv, + int collect) /* Flag == 1 to collect and return loop body result. */ +{ Interp *iPtr = (Interp *) interp; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; @@ -2376,6 +2402,7 @@ DictForNRCmd( return TCL_ERROR; } searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); + searchPtr->resultList = (collect ? Tcl_NewListObj(0, NULL) : NULL ); if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj, &done) != TCL_OK) { TclStackFree(interp, searchPtr); @@ -2419,7 +2446,7 @@ DictForNRCmd( * Run the script. */ - TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj, + TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj, valueVarObj, scriptObj); return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); @@ -2437,7 +2464,7 @@ DictForNRCmd( } static int -DictForLoopCallback( +DictEachLoopCallback( ClientData data[], Tcl_Interp *interp, int result) @@ -2462,19 +2489,34 @@ DictForLoopCallback( result = TCL_OK; } else if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"dict for\" body line %d)", + ((searchPtr->resultList == NULL) ? + "\n (\"dict for\" body line %d)" : + "\n (\"dict map\" body line %d)"), Tcl_GetErrorLine(interp))); } goto done; } /* + * Capture result if collecting. + */ + + if (searchPtr->resultList != NULL) { + Tcl_ListObjAppendElement(interp, searchPtr->resultList, Tcl_GetObjResult(interp)); + } + + /* * Get the next mapping from the dictionary. */ Tcl_DictObjNext(searchPtr, &keyObj, &valueObj, &done); if (done) { - Tcl_ResetResult(interp); + if (searchPtr->resultList != NULL) { + Tcl_SetObjResult(interp, searchPtr->resultList); + searchPtr->resultList = NULL; /* Don't clean it up */ + } else { + Tcl_ResetResult(interp); + } goto done; } @@ -2499,7 +2541,7 @@ DictForLoopCallback( * Run the script. */ - TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj, + TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj, valueVarObj, scriptObj); return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); @@ -2507,9 +2549,12 @@ DictForLoopCallback( * For unwinding everything once the iterating is done. */ - done: +done: TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); + if (searchPtr->resultList != NULL) { + TclDecrRefCount(searchPtr->resultList); + } TclDecrRefCount(scriptObj); Tcl_DictObjDone(searchPtr); TclStackFree(interp, searchPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e402634..952eb32 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5492,7 +5492,15 @@ TEBCresume( opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); goto gotError; } - if (listLen > iterNum * numVars) { + + /* If the accumulator is the only variable then this list gets + * just one iteration. Otherwise we must keep going until the + * list is exhausted by non-accumulator loop vars */ + j = ((i == 0) && (iterNum > 0) + && (infoPtr->collect == TCL_EACH_ACCUM)); + /* j is 1 if the accumulator is present but does not consume + * an element, or 0 otherwise (consuming or not-present). */ + if ((numVars > j) && (listLen > (iterNum * (numVars - j) + j))) { continueLoop = 1; } listTmpIndex++; @@ -5517,8 +5525,11 @@ TEBCresume( listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); TclListObjGetElements(interp, listPtr, &listLen, &elements); - valIndex = (iterNum * numVars); - for (j = 0; j < numVars; j++) { + /* Don't modify the accumulator except on the first iteration */ + j = ((i == 0) && (iterNum > 0) + && (infoPtr->collect == TCL_EACH_ACCUM)); + valIndex = (iterNum * (numVars - j) + j); + for (; j < numVars; j++) { if (valIndex >= listLen) { TclNewObj(valuePtr); } else { diff --git a/generic/tclInt.h b/generic/tclInt.h index 53a88d6..6600dd9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2773,7 +2773,9 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachaCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRMapeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; @@ -2854,6 +2856,19 @@ struct Tcl_LoadHandle_ { #define TCL_DD_SHORTEST0 0x0 /* 'Shortest possible' after masking */ +/* Modes for collecting or accumulating in TclNREachloopCmd, + * TclCompileEachloopCmd and INST_FOREACH_STEP4. */ + +#define TCL_EACH_KEEP_NONE 0 + /* Discard iteration result like [foreach] */ + +#define TCL_EACH_COLLECT 1 + /* Collect iteration result like [mapeach] */ + +#define TCL_EACH_ACCUM 2 + /* First loop var is accumulator like [foreacha] */ + + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: @@ -3299,6 +3314,9 @@ MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ForeachaObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3366,6 +3384,9 @@ MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_MapeachObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy, Tcl_Interp *interp, int objc, @@ -3492,6 +3513,9 @@ MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3525,6 +3549,9 @@ MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileForeachaCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3561,6 +3588,9 @@ MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileMapeachCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/tests/dict.test b/tests/dict.test index 77bacf6..398493a 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1521,6 +1521,252 @@ j }} [linenumber]}} } 5 rename linenumber {} + +test dict-24.1 {dict map command: syntax} -returnCodes error -body { + dict map +} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +test dict-24.2 {dict map command: syntax} -returnCodes error -body { + dict map x +} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +test dict-24.3 {dict map command: syntax} -returnCodes error -body { + dict map x x +} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +test dict-24.4 {dict map command: syntax} -returnCodes error -body { + dict map x x x x +} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +test dict-24.5 {dict map command: syntax} -returnCodes error -body { + dict map x x x +} -result {must have exactly two variable names} +test dict-24.6 {dict map command: syntax} -returnCodes error -body { + dict map {x x x} x x +} -result {must have exactly two variable names} +test dict-24.7 {dict map command: syntax} -returnCodes error -body { + dict map "\{x" x x +} -result {unmatched open brace in list} +test dict-24.8 {dict map command} -body { + # This test confirms that [dict keys], [dict values] and [dict map] + # all traverse a dictionary in the same order. + set dictv {a A b B c C} + set values {} + set keys [dict map {k v} $dictv { + lappend values $v + set k + }] + set result [expr { + $keys eq [dict keys $dictv] && $values eq [dict values $dictv] + }] + expr {$result ? "YES" : [list "NO" $dictv $keys $values]} +} -cleanup { + unset result keys values k v dictv +} -result YES +test dict-24.9 {dict map command} { + dict map {k v} {} { + error "unexpected execution of 'dict map' body" + } +} {} +test dict-24.10 {dict map command: script results} -body { + set times 0 + dict map {k v} {a a b b} { + incr times + continue + error "shouldn't get here" + } + return $times +} -cleanup { + unset times k v +} -result 2 +test dict-24.11 {dict map command: script results} -body { + set times 0 + dict map {k v} {a a b b} { + incr times + break + error "shouldn't get here" + } + return $times +} -cleanup { + unset times k v +} -result 1 +test dict-24.12 {dict map command: script results} -body { + set times 0 + list [catch { + dict map {k v} {a a b b} { + incr times + error test + } + } msg] $msg $times $::errorInfo +} -cleanup { + unset times k v msg +} -result {1 test 1 {test + while executing +"error test" + ("dict map" body line 3) + invoked from within +"dict map {k v} {a a b b} { + incr times + error test + }"}} +test dict-24.13 {dict map command: script results} { + apply {{} { + dict map {k v} {a b} { + return ok,$k,$v + error "skipped return completely" + } + error "return didn't go far enough" + }} +} ok,a,b +test dict-24.14 {dict map command: handle representation loss} -body { + set dictVar {a b c d e f g h} + set values {} + set keys [dict map {k v} $dictVar { + if {[llength $dictVar]} { + lappend values $v + return -level 0 $k + } + }] + list [lsort $keys] [lsort $values] +} -cleanup { + unset dictVar keys values k v +} -result {{a c e g} {b d f h}} +test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup { + unset -nocomplain accum + array set accum {} +} -body { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + dict map {k v} $dictVar { + append accum($k) $v, + } + set result [lsort [array names accum]] + lappend result : + foreach k $result { + catch {lappend result $accum($k)} + } + return $result +} -cleanup { + unset dictVar k v result accum +} -result {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,} +test dict-24.16 {dict map command in compilation context} { + apply {{} { + set res {x x x x x x} + dict map {k v} {a 0 b 1 c 2 d 3 e 4 f 5} { + lset res $v $k + continue + } + return $res + }} +} {a b c d e f} +test dict-24.17 {dict map command in compilation context} { + # Bug 1379349 (dict for) + apply {{} { + set d [dict create a 1] ;# Dict must be unshared! + dict map {k v} $d { + dict set d $k 0 ;# Any modification will do + } + return $d + }} +} {a 0} +test dict-24.17a {dict map command in compilation context} { + # Bug 1379349 (dict for) + apply {{} { + set d [dict create a 1] ;# Dict must be unshared! + dict map {k v} $d { + dict set d $k 0 ;# Any modification will do + } + }} +} {{a 0}} +test dict-24.18 {dict map command in compilation context} { + # Bug 1382528 (dict for) + apply {{} { + dict map {k v} {} {} ;# Note empty dict + catch { error foo } ;# Note compiled [catch] + }} +} 1 +test dict-24.19 {dict map and invalid dicts: 'dict for' bug 1531184} -body { + di[list]ct map {k v} x {} +} -returnCodes 1 -result {missing value to go with key} +test dict-24.20 {dict map stack space compilation: 'dict for' bug 1903325} { + apply {{x y args} { + dict map {a b} $x {} + concat "c=$y,$args" + }} {} 1 2 3 +} {c=1,2 3} +proc linenumber {} { + dict get [info frame -1] line +} +test dict-24.20 {dict compilation crash: 'dict for' bug 3487626} { + apply {{} {apply {n { + set e {} + set k {} + dict map {a b} {c {d {e {f g}}}} { + ::tcl::dict::map {h i} $b { + dict update i e j { + ::tcl::dict::update j f k { + return [expr {$n - [linenumber]}] + } + } + } + } + }} [linenumber]}} +} 5 +test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug { + apply {{} {apply {n { + set e {} + set k {} + dict map {a { +b +}} {c {d {e {f g}}}} { + ::tcl::dict::map {h { +i +}} ${ +b +} { + dict update { +i +} e { +j +} { + ::tcl::dict::update { +j +} f k { + return [expr {$n - [linenumber]}] + } + } + } + } + }} [linenumber]}} +} 5 +rename linenumber {} +test dict-24.22 {dict map results (non-compiled)} { + dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { + return -level 0 "$k,$v" + } +} {{1 a,2 b} {3 c,4 d}} +test dict-24.23 {dict map results (compiled)} { + apply {{} { + dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { + return -level 0 "$k,$v" + } + }} +} {{1 a,2 b} {3 c,4 d}} +test dict-24.23a {dict map results (compiled)} { + apply {{list} { + dict map {k v} [dict map {k v} $list { list $v $k }] { + return -level 0 "$k,$v" + } + }} {a 1 b 2 c 3 d 4} +} {{1 a,2 b} {3 c,4 d}} +test dict-24.24 {dict map with huge dict (non-compiled)} { + tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 1000000 x] x] { + expr { $k * $v } + }] +} 166666416666500000 +test dict-24.25 {dict map with huge dict (compiled)} { + apply {{n} { + tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat $n y] y] { + expr { $k * $v } + }] + }} 1000000 +} 166666416666500000 + # cleanup ::tcltest::cleanupTests diff --git a/tests/foreach.test b/tests/foreach.test index a4b652a..6c69b29 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -266,6 +266,15 @@ test foreach-10.1 {foreach: [Bug 1671087]} -setup { rename demo {} } -result {} +test foreach-11.1 {error then dereference loop var (dev bug)} { + catch { foreach a 0 b {1 2 3} { error x } } + set a +} 0 +test foreach-11.2 {error then dereference loop var (dev bug)} { + catch { foreach a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 + # cleanup catch {unset a} catch {unset x} diff --git a/tests/foreacha.test b/tests/foreacha.test new file mode 100644 index 0000000..09a90e4 --- /dev/null +++ b/tests/foreacha.test @@ -0,0 +1,217 @@ +# Commands covered: foreach, continue, break +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +catch {unset a} +catch {unset x} + +# ----- Basic "foreacha" operation (non-compiled) ------------------------------ + +test foreacha-1.1 {basic foreacha tests (non-compiled) - foldl/reduce with initial value} { + set x {} + set c [foreacha a 0 b {1 2 3 4} { lappend x $a ; incr a $b }] + list $a $b $c $x +} {10 4 10 {0 1 3 6}} + +test foreacha-1.2 {basic foreacha tests (non-compiled) - foldl/reduce without initial value} { + set x {} + set c [foreacha {a b} {1 2 3 4 5 6} { lappend x $a ; incr a $b }] + list $a $b $c $x +} {21 6 21 {1 3 6 10 15}} + +test foreacha-1.3 {basic foreacha tests (non-compiled) - filter} { + foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } { lappend a $b } } +} {2 4 6} + +test foreacha-1.3.1 {basic foreacha tests (non-compiled) - filter (via continue)} { + foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } continue; lappend a $b } +} {1 3 5} + +test foreacha-1.4 {basic foreacha tests (non-compiled) - map} { + foreacha a {} b {1 2 3 4 5 6} { lappend a [lrepeat $b $b] } +} {1 {2 2} {3 3 3} {4 4 4 4} {5 5 5 5 5} {6 6 6 6 6 6}} + +test foreacha-1.5 {basic foreacha tests (non-compiled) - prefix (via break)} { + foreacha a {} b {1 2 3 4 5 6} { if { $b > 4 } break; lappend a $b } +} {1 2 3 4} + +test foreacha-1.6 {basic foreacha tests (non-compiled) - accumulator doesn't iterate} { + set x {} + set b [foreacha a {1 2 3 4} { lappend x $a }] + list $a $b $x +} {1 1 1} + +test foreacha-1.7 {basic foreacha tests (non-compiled) - accumulator doesn't iterate} { + set x {} + set c [foreacha a {1 2 3 4} b 0 { lappend x $a $b ; append a $b ; append b $a }] + list $a $b $c $x +} {10 010 10 {1 0}} + +test foreacha-1.8 {basic foreacha tests (non-compiled) - huge list} { + foreacha {a b} [lsearch -all [lrepeat 1000000 x] x] { incr a $b } +} 499999500000 + +test foreacha-1.9 {basic foreacha tests (non-compiled) - spaghetti} { + foreacha {a b} [foreacha a {} {b c} [lsearch -all [lrepeat 1000 x] x] { + lappend a [expr { $b * $c }] + }] { + incr a $b + } +} 166416500 + +test foreacha-1.9.1 {basic foreacha tests (non-compiled) - spaghetti with mapeach} { + foreacha {a b} [mapeach {b c} [lsearch -all [lrepeat 1000 x] x] { + expr { $b * $c } + }] { + incr a $b + } +} 166416500 + +test foreacha-1.10 {basic foreacha tests (non-compiled) - nested} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + incr a [foreacha c 10 d [lrepeat $b $b] { incr c $b }] + } +} 332843490 + +test foreacha-1.10.1 {basic foreacha tests (non-compiled) - nested with loop var collision} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + foreacha a 10 b [lrepeat $b $b] { incr a $b } + } +} 998011 + +test foreacha-1.10.2 {basic foreacha tests (non-compiled) - nested, inner non-compiled} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + incr a [eval foreacha c 10 d [list [lrepeat $b $b] { incr c $b }]] + } +} 332843490 + + +# ----- Basic "foreacha" operation (compiled) ---------------------------------- + +test foreacha-2.1 {basic foreacha tests (compiled) - foldl/reduce with initial value} { + apply {{} { + set x {} + set c [foreacha a 0 b {1 2 3 4} { lappend x $a ; incr a $b }] + list $a $b $c $x + }} +} {10 4 10 {0 1 3 6}} + +test foreacha-2.2 {basic foreacha tests (compiled) - foldl/reduce without initial value} { + apply {{} { + set x {} + set c [foreacha {a b} {1 2 3 4 5 6} { lappend x $a ; incr a $b }] + list $a $b $c $x + }} +} {21 6 21 {1 3 6 10 15}} + +test foreacha-2.3 {basic foreacha tests (compiled) - filter} { + apply {{} { + foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } { lappend a $b } } + }} +} {2 4 6} + +test foreacha-2.3.1 {basic foreacha tests (non-compiled) - filter (via continue)} { + apply {{} { + foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } continue; lappend a $b } + }} +} {1 3 5} + +test foreacha-2.4 {basic foreacha tests (compiled) - map} { + apply {{} { + foreacha a {} b {1 2 3 4 5 6} { lappend a [lrepeat $b $b] } + }} +} {1 {2 2} {3 3 3} {4 4 4 4} {5 5 5 5 5} {6 6 6 6 6 6}} + +test foreacha-2.5 {basic foreacha tests (non-compiled) - prefix (via break)} { + apply {{} { + foreacha a {} b {1 2 3 4 5 6} { if { $b > 4 } break; lappend a $b } + }} +} {1 2 3 4} + +test foreacha-2.6 {basic foreacha tests (compiled) - accumulator doesn't iterate} { + apply {{} { + set x {} + set b [foreacha a {1 2 3 4} { lappend x $a }] + list $a $b $x + }} +} {1 1 1} + +test foreacha-2.7 {basic foreacha tests (compiled) - accumulator doesn't iterate} { + apply {{} { + set x {} + set c [foreacha a {1 2 3 4} b 0 { lappend x $a $b ; append a $b ; append b $a }] + list $a $b $c $x + }} +} {10 010 10 {1 0}} + +test foreacha-2.8 {basic foreacha tests (compiled) - huge list} { + apply {{} { + foreacha {a b} [lsearch -all [lrepeat 1000000 x] x] { incr a $b } + }} +} 499999500000 + +test foreacha-2.9 {basic foreacha tests (compiled) - spaghetti} { + apply {{} { + foreacha {a b} [foreacha a {} {b c} [lsearch -all [lrepeat 1000 x] x] { + lappend a [expr { $b * $c }] + }] { + incr a $b + } + }} +} 166416500 + +test foreacha-2.9.1 {basic foreacha tests (compiled) - spaghetti with mapeach} { + apply {{} { + foreacha {a b} [mapeach {b c} [lsearch -all [lrepeat 1000 x] x] { + expr { $b * $c } + }] { + incr a $b + } + }} +} 166416500 + +test foreacha-2.10 {basic foreacha tests (compiled) - nested} { + apply {{} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + incr a [foreacha c 10 d [lrepeat $b $b] { incr c $b }] + } + }} +} 332843490 + +test foreacha-2.10.1 {basic foreacha tests (compiled) - nested with loop var collision} { + apply {{} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + foreacha a 10 b [lrepeat $b $b] { incr a $b } + } + }} +} 998011 + +test foreacha-2.10.2 {basic foreacha tests (compiled) - nested, inner non-compiled} { + apply {{} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + incr a [eval foreacha c 10 d [list [lrepeat $b $b] { incr c $b }]] + } + }} +} 332843490 + + + +# cleanup +catch {unset a} +catch {unset x} +catch {rename foo {}} +::tcltest::cleanupTests +return diff --git a/tests/mapeach.test b/tests/mapeach.test new file mode 100644 index 0000000..9ad9d72 --- /dev/null +++ b/tests/mapeach.test @@ -0,0 +1,493 @@ +# Commands covered: mapeach, continue, break +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 2011 Trevor Davel +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +catch {unset a} +catch {unset i} +catch {unset x} + +# ----- Non-compiled operation ------------------------------------------------- + + +# Basic "mapeach" operation (non-compiled) + +test mapeach-1.1 {basic mapeach tests} { + set a {} + mapeach i {a b c d} { + set a [concat $a $i] + } +} {a {a b} {a b c} {a b c d}} +test mapeach-1.2 {basic mapeach tests} { + mapeach i {a b {{c d} e} {123 {{x}}}} { + set i + } +} {a b {{c d} e} {123 {{x}}}} +test mapeach-1.2a {basic mapeach tests} { + mapeach i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } +} {a b {{c d} e} {123 {{x}}}} +test mapeach-1.3 {basic mapeach tests} {catch {mapeach} msg} 1 +test mapeach-1.4 {basic mapeach tests} { + catch {mapeach} msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-1.5 {basic mapeach tests} {catch {mapeach i} msg} 1 +test mapeach-1.6 {basic mapeach tests} { + catch {mapeach i} msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-1.7 {basic mapeach tests} {catch {mapeach i j} msg} 1 +test mapeach-1.8 {basic mapeach tests} { + catch {mapeach i j} msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-1.9 {basic mapeach tests} {catch {mapeach i j k l} msg} 1 +test mapeach-1.10 {basic mapeach tests} { + catch {mapeach i j k l} msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-1.11 {basic mapeach tests} { + mapeach i {} { + set i + } +} {} +test mapeach-1.12 {basic mapeach tests} { + mapeach i {} { + return -level 0 x + } +} {} +test mapeach-1.13 {mapeach errors} { + list [catch {mapeach {{a}{b}} {1 2 3} {}} msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test mapeach-1.14 {mapeach errors} { + list [catch {mapeach a {{1 2}3} {}} msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test mapeach-1.15 {mapeach errors} { + catch {unset a} + set a(0) 44 + list [catch {mapeach a {1 2 3} {}} msg o] $msg $::errorInfo +} {1 {can't set "a": variable is array} {can't set "a": variable is array + (setting foreach loop variable "a") + invoked from within +"mapeach a {1 2 3} {}"}} +test mapeach-1.16 {mapeach errors} { + list [catch {mapeach {} {} {}} msg] $msg +} {1 {foreach varlist is empty}} +catch {unset a} + + +# Parallel "mapeach" operation (non-compiled) + +test mapeach-2.1 {parallel mapeach tests} { + mapeach {a b} {1 2 3 4} { + list $b $a + } +} {{2 1} {4 3}} +test mapeach-2.2 {parallel mapeach tests} { + mapeach {a b} {1 2 3 4 5} { + list $b $a + } +} {{2 1} {4 3} {{} 5}} +test mapeach-2.3 {parallel mapeach tests} { + mapeach a {1 2 3} b {4 5 6} { + list $b $a + } +} {{4 1} {5 2} {6 3}} +test mapeach-2.4 {parallel mapeach tests} { + mapeach a {1 2 3} b {4 5 6 7 8} { + list $b $a + } +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test mapeach-2.5 {parallel mapeach tests} { + mapeach {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test mapeach-2.6 {parallel mapeach tests} { + mapeach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } +} {11111 22222 33333} +test mapeach-2.7 {parallel mapeach tests} { + mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } +} {{1111 2} 222 33 4} +test mapeach-2.8 {parallel mapeach tests} { + mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test mapeach-2.9 {mapeach only sets vars if repeating loop} { + namespace eval ::mapeach_test { + set rgb {65535 0 0} + mapeach {r g b} [set rgb] {} + set ::x "r=$r, g=$g, b=$b" + } + namespace delete ::mapeach_test + set x +} {r=65535, g=0, b=0} +test mapeach-2.10 {mapeach only supports local scalar variables} { + catch { unset a } + mapeach {a(3)} {1 2 3 4} {set {a(3)}} +} {1 2 3 4} +catch { unset a } + + +# "mapeach" with "continue" and "break" (non-compiled) + +test mapeach-3.1 {continue tests} { + mapeach i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } +} {a c d} +test mapeach-3.2 {continue tests} { + set x 0 + list [mapeach i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x +} {b 4} +test mapeach-3.3 {break tests} { + set x 0 + list [mapeach i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x +} {{a b} 3} +# Check for bug similar to #406709 +test mapeach-3.4 {break tests} { + set a 1 + mapeach b b {list [concat a; break]; incr a} + incr a +} {2} + + +# ----- Compiled operation ------------------------------------------------------ + +# Basic "mapeach" operation (compiled) + +test mapeach-4.1 {basic mapeach tests} { + apply {{} { + set a {} + mapeach i {a b c d} { + set a [concat $a $i] + } + }} +} {a {a b} {a b c} {a b c d}} +test mapeach-4.2 {basic mapeach tests} { + apply {{} { + mapeach i {a b {{c d} e} {123 {{x}}}} { + set i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test mapeach-4.2a {basic mapeach tests} { + apply {{} { + mapeach i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test mapeach-4.3 {basic mapeach tests} {catch { apply {{} { mapeach }} } msg} 1 +test mapeach-4.4 {basic mapeach tests} { + catch { apply {{} { mapeach }} } msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-4.5 {basic mapeach tests} {catch { apply {{} { mapeach i }} } msg} 1 +test mapeach-4.6 {basic mapeach tests} { + catch { apply {{} { mapeach i }} } msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-4.7 {basic mapeach tests} {catch { apply {{} { mapeach i j }} } msg} 1 +test mapeach-4.8 {basic mapeach tests} { + catch { apply {{} { mapeach i j }} } msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-4.9 {basic mapeach tests} {catch { apply {{} { mapeach i j k l }} } msg} 1 +test mapeach-4.10 {basic mapeach tests} { + catch { apply {{} { mapeach i j k l }} } msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-4.11 {basic mapeach tests} { + apply {{} { mapeach i {} { set i } }} +} {} +test mapeach-4.12 {basic mapeach tests} { + apply {{} { mapeach i {} { return -level 0 x } }} +} {} +test mapeach-4.13 {mapeach errors} { + list [catch { apply {{} { mapeach {{a}{b}} {1 2 3} {} }} } msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test mapeach-4.14 {mapeach errors} { + list [catch { apply {{} { mapeach a {{1 2}3} {} }} } msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test mapeach-4.15 {mapeach errors} { + apply {{} { + set a(0) 44 + list [catch {mapeach a {1 2 3} {}} msg o] $msg $::errorInfo + }} +} {1 {can't set "a": variable is array} {can't set "a": variable is array + while executing +"mapeach a {1 2 3} {}"}} +test mapeach-4.16 {mapeach errors} { + list [catch { apply {{} { mapeach {} {} {} }} } msg] $msg +} {1 {foreach varlist is empty}} +catch {unset a} + + +# Parallel "mapeach" operation (compiled) + +test mapeach-5.1 {parallel mapeach tests} { + apply {{} { + mapeach {a b} {1 2 3 4} { + list $b $a + } + }} +} {{2 1} {4 3}} +test mapeach-5.2 {parallel mapeach tests} { + apply {{} { + mapeach {a b} {1 2 3 4 5} { + list $b $a + } + }} +} {{2 1} {4 3} {{} 5}} +test mapeach-5.3 {parallel mapeach tests} { + apply {{} { + mapeach a {1 2 3} b {4 5 6} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3}} +test mapeach-5.4 {parallel mapeach tests} { + apply {{} { + mapeach a {1 2 3} b {4 5 6 7 8} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test mapeach-5.5 {parallel mapeach tests} { + apply {{} { + mapeach {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } + }} +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test mapeach-5.6 {parallel mapeach tests} { + apply {{} { + mapeach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } + }} +} {11111 22222 33333} +test mapeach-5.7 {parallel mapeach tests} { + apply {{} { + mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } + }} +} {{1111 2} 222 33 4} +test mapeach-5.8 {parallel mapeach tests} { + apply {{} { + mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } + }} +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test mapeach-5.9 {mapeach only sets vars if repeating loop} { + apply {{} { + set rgb {65535 0 0} + mapeach {r g b} [set rgb] {} + return "r=$r, g=$g, b=$b" + }} +} {r=65535, g=0, b=0} +test mapeach-5.10 {mapeach only supports local scalar variables} { + apply {{} { + mapeach {a(3)} {1 2 3 4} {set {a(3)}} + }} +} {1 2 3 4} + + +# "mapeach" with "continue" and "break" (compiled) + +test mapeach-6.1 {continue tests} { + apply {{} { + mapeach i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } + }} +} {a c d} +test mapeach-6.2 {continue tests} { + apply {{} { + list [mapeach i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x + }} +} {b 4} +test mapeach-6.3 {break tests} { + apply {{} { + list [mapeach i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x + }} +} {{a b} 3} +# Check for bug similar to #406709 +test mapeach-6.4 {break tests} { + apply {{} { + set a 1 + mapeach b b {list [concat a; break]; incr a} + incr a + }} +} {2} + + + +# ----- Special cases and bugs ------------------------------------------------- + + +test mapeach-7.1 {compiled mapeach backward jump works correctly} { + catch {unset x} + array set x {0 zero 1 one 2 two 3 three} + lsort [apply {{arrayName} { + upvar 1 $arrayName a + mapeach member [array names a] { + list $member [set a($member)] + } + }} x] +} [lsort {{0 zero} {1 one} {2 two} {3 three}}] + +test mapeach-7.2 {noncompiled mapeach and shared variable or value list objects that are converted to another type} { + catch {unset x} + mapeach {12.0} {a b c} { + set x 12.0 + set x [expr $x + 1] + } +} {13.0 13.0 13.0} + +# Test for incorrect "double evaluation" semantics +test mapeach-7.3 {delayed substitution of body} { + apply {{} { + set a 0 + mapeach a [list 1 2 3] " + set x $a + " + set x + }} +} {0} + +# Related to "foreach" test for [Bug 1189274]; crash on failure +test mapeach-7.4 {empty list handling} { + proc crash {} { + rename crash {} + set a "x y z" + set b "" + mapeach aa $a bb $b { set x "aa = $aa bb = $bb" } + } + crash +} {{aa = x bb = } {aa = y bb = } {aa = z bb = }} + +# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled version +test mapeach-7.5 {compiled empty var list} { + proc foo {} { + mapeach {} x { + error "reached body" + } + } + list [catch { foo } msg] $msg +} {1 {foreach varlist is empty}} + +test mapeach-7.6 {mapeach: related to "foreach" [Bug 1671087]} -setup { + proc demo {} { + set vals {1 2 3 4} + trace add variable x write {string length $vals ;# } + mapeach {x y} $vals {format $y} + } +} -body { + demo +} -cleanup { + rename demo {} +} -result {2 4} + +# Huge lists must not overflow the bytecode interpreter (development bug) +test mapeach-7.7 {huge list non-compiled} { + set x [mapeach a [lrepeat 1000000 x] { set b y$a }] + list $b [llength $x] [string length $x] +} {yx 1000000 2999999} + +test mapeach-7.8 {huge list compiled} { + set x [apply {{times} { mapeach a [lrepeat $times x] { set b y$a }}} 1000000] + list $b [llength $x] [string length $x] +} {yx 1000000 2999999} + +test mapeach-7.9 {error then dereference loop var (dev bug)} { + catch { mapeach a 0 b {1 2 3} { error x } } + set a +} 0 +test mapeach-7.9a {error then dereference loop var (dev bug)} { + catch { mapeach a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 + +# ----- Coroutines ------------------------------------------------------------- + +test mapeach-8.1 {mapeach non-compiled with coroutines} { + coroutine coro apply {{} { + set values [yield [info coroutine]] + eval mapeach i [list $values] {{ yield $i }} + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} {{1 2 3 4 5 6} {}} + +test mapeach-8.2 {mapeach compiled with coroutines} { + coroutine coro apply {{} { + set values [yield [info coroutine]] + mapeach i $values { yield $i } + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} {{1 2 3 4 5 6} {}} + + +# cleanup +catch {unset a} +catch {unset x} +catch {rename foo {}} +::tcltest::cleanupTests +return -- cgit v0.12 From 1121067971e449803e3964d69958d35e2187af2a Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 4 Aug 2012 07:41:11 +0000 Subject: more result generation conversion --- generic/tclInterp.c | 101 ++++++++++++++++++++++++++++------------------------ generic/tclLoad.c | 57 +++++++++++++++-------------- generic/tclNamesp.c | 64 ++++++++++++++++----------------- generic/tclObj.c | 42 +++++++++++----------- generic/tclPipe.c | 93 +++++++++++++++++++++++++---------------------- generic/tclPkg.c | 99 +++++++++++++++++++++++++------------------------- generic/tclProc.c | 71 ++++++++++++++++++------------------ generic/tclZlib.c | 62 +++++++++++++++++--------------- tests/format.test | 7 ++-- 9 files changed, 310 insertions(+), 286 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 5bae041..0b0f652 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1043,18 +1043,18 @@ Tcl_InterpObjCmd( iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", - Tcl_GetString(objv[2]), "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" in path \"%s\" not found", + aliasName, Tcl_GetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "target interpreter for alias \"", - aliasName, "\" in path \"", Tcl_GetString(objv[2]), - "\" is not my descendant", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "target interpreter for alias \"%s\" in path \"%s\" is " + "not my descendant", aliasName, Tcl_GetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "TARGETSHROUDED", NULL); return TCL_ERROR; @@ -1234,7 +1234,8 @@ Tcl_GetAlias( hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } @@ -1295,7 +1296,8 @@ Tcl_GetAliasObj( hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } @@ -1383,9 +1385,9 @@ TclPreventAliasLoop( * [Bug #641195] */ - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": interpreter deleted", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot define or rename alias \"%s\": interpreter deleted", + Tcl_GetCommandName(cmdInterp, cmd))); return TCL_ERROR; } cmdNamePtr = nextAliasPtr->objPtr; @@ -1398,9 +1400,9 @@ TclPreventAliasLoop( } aliasCmdPtr = (Command *) aliasCmd; if (aliasCmdPtr == cmdPtr) { - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": would create a loop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot define or rename alias \"%s\": would create a loop", + Tcl_GetCommandName(cmdInterp, cmd))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "ALIASLOOP", NULL); return TCL_ERROR; @@ -1621,8 +1623,8 @@ AliasDelete( slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", TclGetString(namePtr), - "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", TclGetString(namePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", TclGetString(namePtr), NULL); return TCL_ERROR; @@ -2220,8 +2222,8 @@ GetInterp( } } if (searchInterp == NULL) { - Tcl_AppendResult(interp, "could not find interpreter \"", - TclGetString(pathPtr), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not find interpreter \"%s\"", TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP", TclGetString(pathPtr), NULL); } @@ -2258,8 +2260,8 @@ SlaveBgerror( if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { - Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cmdPrefix must be list of length >= 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BGERRORFORMAT", NULL); return TCL_ERROR; @@ -2328,8 +2330,9 @@ SlaveCreate( hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &isNew); if (isNew == 0) { - Tcl_AppendResult(interp, "interpreter named \"", path, - "\" already exists, cannot create", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "interpreter named \"%s\" already exists, cannot create", + path)); return NULL; } @@ -2862,8 +2865,8 @@ SlaveRecursionLimit( if (objc) { if (Tcl_IsSafe(interp)) { - Tcl_AppendResult(interp, "permission denied: " - "safe interpreters cannot change recursion limit", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: " + "safe interpreters cannot change recursion limit", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", NULL); return TCL_ERROR; @@ -3322,8 +3325,8 @@ Tcl_LimitCheck( if (iPtr->limit.cmdCount >= iPtr->cmdCount) { iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "command count limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command count limit exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); Tcl_Release(interp); return TCL_ERROR; @@ -3348,8 +3351,8 @@ Tcl_LimitCheck( iPtr->limit.time.usec >= now.usec)) { iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "time limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "time limit exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL); Tcl_Release(interp); return TCL_ERROR; @@ -4355,8 +4358,9 @@ SlaveCommandLimitCmd( */ if (interp == slaveInterp) { - Tcl_AppendResult(interp, - "limits on current interpreter inaccessible", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "limits on current interpreter inaccessible", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); return TCL_ERROR; } @@ -4452,8 +4456,8 @@ SlaveCommandLimitCmd( return TCL_ERROR; } if (gran < 1) { - Tcl_AppendResult(interp, "granularity must be at " - "least 1", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "granularity must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; @@ -4469,8 +4473,8 @@ SlaveCommandLimitCmd( return TCL_ERROR; } if (limit < 0) { - Tcl_AppendResult(interp, "command limit value must be at " - "least 0", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command limit value must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; @@ -4542,8 +4546,9 @@ SlaveTimeLimitCmd( */ if (interp == slaveInterp) { - Tcl_AppendResult(interp, - "limits on current interpreter inaccessible", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "limits on current interpreter inaccessible", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); return TCL_ERROR; } @@ -4660,8 +4665,8 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (gran < 1) { - Tcl_AppendResult(interp, "granularity must be at " - "least 1", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "granularity must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; @@ -4677,13 +4682,13 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (tmp < 0) { - Tcl_AppendResult(interp, "milliseconds must be at least 0", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "milliseconds must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } - limitMoment.usec = ((long)tmp)*1000; + limitMoment.usec = ((long) tmp)*1000; break; case OPT_SEC: secObj = objv[i+1]; @@ -4695,8 +4700,8 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (tmp < 0) { - Tcl_AppendResult(interp, "seconds must be at least 0", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "seconds must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; @@ -4713,15 +4718,17 @@ SlaveTimeLimitCmd( */ if (secObj != NULL && secLen == 0 && milliLen > 0) { - Tcl_AppendResult(interp, "may only set -milliseconds " - "if -seconds is not also being reset", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may only set -milliseconds if -seconds is not " + "also being reset", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADUSAGE", NULL); return TCL_ERROR; } if (milliLen == 0 && (secObj == NULL || secLen > 0)) { - Tcl_AppendResult(interp, "may only reset -milliseconds " - "if -seconds is also being reset", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may only reset -milliseconds if -seconds is " + "also being reset", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADUSAGE", NULL); return TCL_ERROR; diff --git a/generic/tclLoad.c b/generic/tclLoad.c index f14cec0..3fead6f 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -224,9 +224,9 @@ Tcl_LoadObjCmd( * Can't have two different packages loaded from the same file. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" is already loaded for package \"", - pkgPtr->packageName, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" is already loaded for package \"%s\"", + fullFileName, pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "SPLITPERSONALITY", NULL); code = TCL_ERROR; @@ -262,8 +262,8 @@ Tcl_LoadObjCmd( */ if (fullFileName[0] == 0) { - Tcl_AppendResult(interp, "package \"", packageName, - "\" isn't loaded statically", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package \"%s\" isn't loaded statically", packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", NULL); code = TCL_ERROR; @@ -320,9 +320,9 @@ Tcl_LoadObjCmd( } if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); - Tcl_AppendResult(interp, - "couldn't figure out package name for ", - fullFileName, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't figure out package name for %s", + fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "WHATPACKAGE", NULL); code = TCL_ERROR; @@ -417,9 +417,9 @@ Tcl_LoadObjCmd( if (Tcl_IsSafe(target)) { if (pkgPtr->safeInitProc == NULL) { - Tcl_AppendResult(interp, - "can't use package in a safe interpreter: no ", - pkgPtr->packageName, "_SafeInit procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't use package in a safe interpreter: no" + " %s_SafeInit procedure", pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", NULL); code = TCL_ERROR; @@ -428,9 +428,9 @@ Tcl_LoadObjCmd( code = pkgPtr->safeInitProc(target); } else { if (pkgPtr->initProc == NULL) { - Tcl_AppendResult(interp, - "can't attach package to interpreter: no ", - pkgPtr->packageName, "_Init procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't attach package to interpreter: no %s_Init procedure", + pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; @@ -653,8 +653,9 @@ Tcl_UnloadObjCmd( * It's an error to try unload a static package. */ - Tcl_AppendResult(interp, "package \"", packageName, - "\" is loaded statically and cannot be unloaded", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package \"%s\" is loaded statically and cannot be unloaded", + packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", NULL); code = TCL_ERROR; @@ -665,8 +666,8 @@ Tcl_UnloadObjCmd( * The DLL pointed by the provided filename has never been loaded. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" has never been loaded", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" has never been loaded", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", NULL); code = TCL_ERROR; @@ -694,8 +695,9 @@ Tcl_UnloadObjCmd( * The package has not been loaded in this interpreter. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" has never been loaded in this interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" has never been loaded in this interpreter", + fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", NULL); code = TCL_ERROR; @@ -710,8 +712,9 @@ Tcl_UnloadObjCmd( if (Tcl_IsSafe(target)) { if (pkgPtr->safeUnloadProc == NULL) { - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded under a safe interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a safe interpreter", + fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", NULL); code = TCL_ERROR; @@ -720,8 +723,9 @@ Tcl_UnloadObjCmd( unloadProc = pkgPtr->safeUnloadProc; } else { if (pkgPtr->unloadProc == NULL) { - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded under a trusted interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a trusted interpreter", + fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", NULL); code = TCL_ERROR; @@ -860,8 +864,9 @@ Tcl_UnloadObjCmd( } } #else - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded: unloading disabled", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded: unloading disabled", + fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", NULL); code = TCL_ERROR; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 6a241f0..3c93400 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -687,9 +687,8 @@ Tcl_CreateNamespace( parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't create namespace \"\": " - "only global namespace can have empty name", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" + " \"\": only global namespace can have empty name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", "CREATEGLOBAL", NULL); return NULL; @@ -725,8 +724,8 @@ Tcl_CreateNamespace( Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL #endif ) { - Tcl_AppendResult(interp, "can't create namespace \"", name, - "\": already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create namespace \"%s\": already exists", name)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", "CREATEEXISTING", NULL); return NULL; @@ -1336,8 +1335,8 @@ Tcl_Export( &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { - Tcl_AppendResult(interp, "invalid export pattern \"", pattern, - "\": pattern can't specify a namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" + " \"%s\": pattern can't specify a namespace", pattern)); Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); return TCL_ERROR; } @@ -1551,21 +1550,21 @@ Tcl_Import( &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { - Tcl_AppendResult(interp, "unknown namespace in import pattern \"", - pattern, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in import pattern \"%s\"", pattern)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { - Tcl_AppendResult(interp, - "no namespace specified in import pattern \"", pattern, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no namespace specified in import pattern \"%s\"", + pattern)); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); } else { - Tcl_AppendResult(interp, "import pattern \"", pattern, - "\" tries to import from namespace \"", - importNsPtr->name, "\" into itself", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" tries to import from namespace" + " \"%s\" into itself", pattern, importNsPtr->name)); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); } return TCL_ERROR; @@ -1684,9 +1683,10 @@ DoImport( dataPtr = linkCmd->objClientData; linkCmd = dataPtr->realCmdPtr; if (overwrite == linkCmd) { - Tcl_AppendResult(interp, "import pattern \"", pattern, - "\" would create a loop containing command \"", - Tcl_DStringValue(&ds), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" would create a loop" + " containing command \"%s\"", + pattern, Tcl_DStringValue(&ds))); Tcl_DStringFree(&ds); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; @@ -1726,8 +1726,8 @@ DoImport( return TCL_OK; } } - Tcl_AppendResult(interp, "can't import command \"", cmdName, - "\": already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't import command \"%s\": already exists", cmdName)); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } @@ -1796,9 +1796,9 @@ Tcl_ForgetImport( &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { - Tcl_AppendResult(interp, - "unknown namespace in namespace forget pattern \"", - pattern, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in namespace forget pattern \"%s\"", + pattern)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } @@ -2402,8 +2402,8 @@ Tcl_FindNamespace( } if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); } return NULL; @@ -2589,8 +2589,8 @@ Tcl_FindCommand( } if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown command \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); } return NULL; @@ -3170,9 +3170,9 @@ NamespaceDeleteCmd( namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { - Tcl_AppendResult(interp, "unknown namespace \"", - TclGetString(objv[i]), - "\" in namespace delete command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\" in namespace delete command", + TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", TclGetString(objv[i]), NULL); return TCL_ERROR; @@ -3834,8 +3834,8 @@ NamespaceOriginCmd( command = Tcl_GetCommandFromObj(interp, objv[1]); if (command == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[1]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", TclGetString(objv[1]), NULL); return TCL_ERROR; diff --git a/generic/tclObj.c b/generic/tclObj.c index 099b67d..74cb29e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4462,11 +4462,8 @@ Tcl_RepresentationCmd( int objc, Tcl_Obj *const objv[]) { - char refcountBuffer[TCL_INTEGER_SPACE+1]; - char objPtrBuffer[TCL_INTEGER_SPACE+3]; - char internalRepBuffer[2*(TCL_INTEGER_SPACE+2)+2]; -#define TCLOBJ_TRUNCATE_STRINGREP 16 - char stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP+1]; + char ptrBuffer[2*TCL_INTEGER_SPACE+6]; + Tcl_Obj *descObj; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); @@ -4479,27 +4476,30 @@ Tcl_RepresentationCmd( * "1872361827361287" */ - sprintf(refcountBuffer, "%d", objv[1]->refCount); - sprintf(objPtrBuffer, "%p", (void *)objv[1]); - Tcl_AppendResult(interp, "value is a ", objv[1]->typePtr ? - objv[1]->typePtr->name : "pure string", " with a refcount of ", - refcountBuffer, ", object pointer at ", objPtrBuffer, NULL); + sprintf(ptrBuffer, "%p", (void *) objv[1]); + descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," + " object pointer at %s", + objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + objv[1]->refCount, ptrBuffer); + if (objv[1]->typePtr) { - sprintf(internalRepBuffer, "%p:%p", - (void *)objv[1]->internalRep.twoPtrValue.ptr1, - (void *)objv[1]->internalRep.twoPtrValue.ptr2); - Tcl_AppendResult(interp, ", internal representation ", - internalRepBuffer, NULL); + sprintf(ptrBuffer, "%p:%p", + (void *) objv[1]->internalRep.twoPtrValue.ptr1, + (void *) objv[1]->internalRep.twoPtrValue.ptr2); + Tcl_AppendPrintfToObj(descObj, ", internal representation %s", + ptrBuffer); } + if (objv[1]->bytes) { - strncpy(stringRepBuffer, objv[1]->bytes, TCLOBJ_TRUNCATE_STRINGREP); - stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP] = 0; - Tcl_AppendResult(interp, ", string representation \"", - stringRepBuffer, objv[1]->length > TCLOBJ_TRUNCATE_STRINGREP ? - "\"..." : "\".", NULL); + Tcl_AppendToObj(descObj, ", string representation \"", -1); + Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, + 16, "..."); + Tcl_AppendToObj(descObj, "\"", -1); } else { - Tcl_AppendResult(interp, ", no string representation.", NULL); + Tcl_AppendToObj(descObj, ", no string representation", -1); } + + Tcl_SetObjResult(interp, descObj); return TCL_OK; } diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 56a1846..83fb818 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -106,9 +106,10 @@ FileForRedirect( if (msg) { Tcl_SetObjResult(interp, msg); } else { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(chan), "\" wasn't opened for ", - ((writing) ? "writing" : "reading"), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for %s", + Tcl_GetChannelName(chan), + ((writing) ? "writing" : "reading"))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADCHAN", NULL); } @@ -141,9 +142,10 @@ FileForRedirect( file = TclpOpenFile(name, flags); Tcl_DStringFree(&nameString); if (file == NULL) { - Tcl_AppendResult(interp, "couldn't ", - ((writing) ? "write" : "read"), " file \"", spec, "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't %s file \"%s\": %s", + (writing ? "write" : "read"), spec, + Tcl_PosixError(interp))); return NULL; } *closePtr = 1; @@ -151,8 +153,8 @@ FileForRedirect( return file; badLastArg: - Tcl_AppendResult(interp, "can't specify \"", arg, - "\" as last word in command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't specify \"%s\" as last word in command", arg)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL); return NULL; } @@ -304,8 +306,8 @@ TclCleanupChildren( msg = "child process lost (is SIGCHLD ignored or trapped?)"; } - Tcl_AppendResult(interp, "error waiting for process to exit: ", - msg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error waiting for process to exit: %s", msg)); } continue; } @@ -335,16 +337,17 @@ TclCleanupChildren( p = Tcl_SignalMsg(WTERMSIG(waitStatus)); Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); - Tcl_AppendResult(interp, "child killed: ", p, "\n", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "child killed: %s\n", p)); } else if (WIFSTOPPED(waitStatus)) { p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); - Tcl_AppendResult(interp, "child suspended: ", p, "\n", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "child suspended: %s\n", p)); } else { - Tcl_AppendResult(interp, - "child wait status didn't make sense\n", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "child wait status didn't make sense\n", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "ODDWAITRESULT", msg1, NULL); } @@ -374,8 +377,9 @@ TclCleanupChildren( result = TCL_ERROR; Tcl_DecrRefCount(objPtr); Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading stderr output file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading stderr output file: %s", + Tcl_PosixError(interp))); } else if (count > 0) { anyErrorInfo = 1; Tcl_SetObjResult(interp, objPtr); @@ -393,7 +397,8 @@ TclCleanupChildren( */ if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) { - Tcl_AppendResult(interp, "child process exited abnormally", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "child process exited abnormally", -1)); } return result; } @@ -570,8 +575,9 @@ TclCreatePipeline( if (*inputLiteral == '\0') { inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1]; if (inputLiteral == NULL) { - Tcl_AppendResult(interp, "can't specify \"", argv[i], - "\" as last word in command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't specify \"%s\" as last word in command", + argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", NULL); goto error; @@ -680,8 +686,9 @@ TclCreatePipeline( */ if (i != argc-1) { - Tcl_AppendResult(interp, "must specify \"", argv[i], - "\" as last word in command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "must specify \"%s\" as last word in command", + argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", NULL); goto error; @@ -739,9 +746,9 @@ TclCreatePipeline( inputFile = TclpCreateTempFile(inputLiteral); if (inputFile == NULL) { - Tcl_AppendResult(interp, - "couldn't create input file for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create input file for command: %s", + Tcl_PosixError(interp))); goto error; } inputClose = 1; @@ -752,9 +759,9 @@ TclCreatePipeline( */ if (TclpCreatePipe(&inputFile, inPipePtr) == 0) { - Tcl_AppendResult(interp, - "couldn't create input pipe for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create input pipe for command: %s", + Tcl_PosixError(interp))); goto error; } inputClose = 1; @@ -781,9 +788,9 @@ TclCreatePipeline( */ if (TclpCreatePipe(outPipePtr, &outputFile) == 0) { - Tcl_AppendResult(interp, - "couldn't create output pipe for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create output pipe for command: %s", + Tcl_PosixError(interp))); goto error; } outputClose = 1; @@ -821,9 +828,9 @@ TclCreatePipeline( errorFile = TclpCreateTempFile(NULL); if (errorFile == NULL) { - Tcl_AppendResult(interp, - "couldn't create error file for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create error file for command: %s", + Tcl_PosixError(interp))); goto error; } *errFilePtr = errorFile; @@ -894,8 +901,8 @@ TclCreatePipeline( } else { argv[lastArg] = NULL; if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) { - Tcl_AppendResult(interp, "couldn't create pipe: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create pipe: %s", Tcl_PosixError(interp))); goto error; } } @@ -1074,15 +1081,17 @@ Tcl_OpenCommandChannel( if (flags & TCL_ENFORCE_MODE) { if ((flags & TCL_STDOUT) && (outPipe == NULL)) { - Tcl_AppendResult(interp, "can't read output from command:" - " standard output was redirected", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't read output from command:" + " standard output was redirected", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADREDIRECT", NULL); goto error; } if ((flags & TCL_STDIN) && (inPipe == NULL)) { - Tcl_AppendResult(interp, "can't write input to command:" - " standard input was redirected", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't write input to command:" + " standard input was redirected", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADREDIRECT", NULL); goto error; @@ -1093,8 +1102,8 @@ Tcl_OpenCommandChannel( numPids, pidPtr); if (channel == NULL) { - Tcl_AppendResult(interp, "pipe for command could not be created", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "pipe for command could not be created", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL); goto error; } diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 730efec..9b6e942 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -154,8 +154,9 @@ Tcl_PkgProvideEx( } return TCL_OK; } - Tcl_AppendResult(interp, "conflicting versions provided for package \"", - name, "\": ", pkgPtr->version, ", then ", version, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "conflicting versions provided for package \"%s\": %s, then %s", + name, pkgPtr->version, version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } @@ -284,9 +285,9 @@ Tcl_PkgRequireEx( */ tclEmptyStringRep = &tclEmptyString; - Tcl_AppendResult(interp, "Cannot load package \"", name, - "\" in standalone executable: This package is not " - "compiled with stub support", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Cannot load package \"%s\" in standalone executable:" + " This package is not compiled with stub support", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); return NULL; } @@ -374,9 +375,10 @@ PkgRequireCore( */ if (pkgPtr->clientData != NULL) { - Tcl_AppendResult(interp, "circular package dependency: " - "attempt to provide ", name, " ", - (char *) pkgPtr->clientData, " requires ", name, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "circular package dependency:" + " attempt to provide %s %s requires %s", + name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return NULL; @@ -494,10 +496,10 @@ PkgRequireCore( Tcl_ResetResult(interp); if (pkgPtr->version == NULL) { code = TCL_ERROR; - Tcl_AppendResult(interp, "attempt to provide package ", - name, " ", versionToProvide, - " failed: no version of package ", name, - " provided", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " no version of package %s provided", + name, versionToProvide, name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", NULL); } else { @@ -517,11 +519,11 @@ PkgRequireCore( ckfree(vi); if (res != 0) { code = TCL_ERROR; - Tcl_AppendResult(interp, - "attempt to provide package ", name, " ", - versionToProvide, " failed: package ", - name, " ", pkgPtr->version, - " provided instead", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "WRONGPROVIDE", NULL); } @@ -530,10 +532,10 @@ PkgRequireCore( } else if (code != TCL_ERROR) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "attempt to provide package ", name, - " ", versionToProvide, " failed: bad return code: ", - TclGetString(codePtr), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " bad return code: %s", + name, versionToProvide, TclGetString(codePtr))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); TclDecrRefCount(codePtr); code = TCL_ERROR; @@ -591,13 +593,9 @@ PkgRequireCore( Tcl_DStringFree(&command); if ((code != TCL_OK) && (code != TCL_ERROR)) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); - - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad return code: ", - TclGetString(codePtr), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", code)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - Tcl_DecrRefCount(codePtr); code = TCL_ERROR; } if (code == TCL_ERROR) { @@ -610,7 +608,8 @@ PkgRequireCore( } if (pkgPtr->version == NULL) { - Tcl_AppendResult(interp, "can't find package ", name, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); return NULL; @@ -628,8 +627,9 @@ PkgRequireCore( ckfree(pkgVersionI); if (!satisfies) { - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "version conflict for package \"%s\": have %s, need", + name, pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); @@ -721,10 +721,11 @@ Tcl_PkgPresentEx( } if (version != NULL) { - Tcl_AppendResult(interp, "package ", name, " ", version, - " is not present", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package %s %s is not present", name, version)); } else { - Tcl_AppendResult(interp, "package ", name, " is not present", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package %s is not present", name)); } Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); return NULL; @@ -1354,8 +1355,8 @@ CheckVersionAndConvert( error: ckfree(ibuf); - Tcl_AppendResult(interp, "expected version number but got \"", string, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected version number but got \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); return TCL_ERROR; } @@ -1617,8 +1618,8 @@ CheckRequirement( * More dashes found after the first. This is wrong. */ - Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", - string, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected versionMin-versionMax but got \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); return TCL_ERROR; } @@ -1670,19 +1671,17 @@ AddRequirementsToResult( Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - if (reqc > 0) { - int i; + Tcl_Obj *result = Tcl_GetObjResult(interp); + int i, length; - for (i = 0; i < reqc; i++) { - int length; - const char *v = Tcl_GetStringFromObj(reqv[i], &length); + for (i = 0; i < reqc; i++) { + const char *v = Tcl_GetStringFromObj(reqv[i], &length); - if ((length & 0x1) && (v[length/2] == '-') - && (strncmp(v, v+((length+1)/2), length/2) == 0)) { - Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL); - } else { - Tcl_AppendResult(interp, " ", v, NULL); - } + if ((length & 0x1) && (v[length/2] == '-') + && (strncmp(v, v+((length+1)/2), length/2) == 0)) { + Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2)); + } else { + Tcl_AppendPrintfToObj(result, " %s", v); } } } @@ -1711,9 +1710,9 @@ AddRequirementsToDString( Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - if (reqc > 0) { - int i; + int i; + if (reqc > 0) { for (i = 0; i < reqc; i++) { TclDStringAppendLiteral(dsPtr, " "); TclDStringAppendObj(dsPtr, reqv[i]); diff --git a/generic/tclProc.c b/generic/tclProc.c index 537008c..933e7d2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -152,22 +152,24 @@ Tcl_ProcObjCmd( &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": unknown namespace", + fullName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": bad procedure name", + fullName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { - Tcl_AppendResult(interp, "can't create procedure \"", procName, - "\" in non-global namespace with name starting with \":\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\" in non-global namespace with" + " name starting with \":\"", procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -518,16 +520,17 @@ TclCreateProc( } if (fieldCount > 2) { ckfree(fieldValues); - Tcl_AppendResult(interp, - "too many fields in argument specifier \"", - argArray[i], "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "too many fields in argument specifier \"%s\"", + argArray[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { ckfree(fieldValues); - Tcl_AppendResult(interp, "argument with no name", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; @@ -553,16 +556,18 @@ TclCreateProc( } while (*q != '\0'); q--; if (*q == ')') { /* We have an array element. */ - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], "\" is an array element", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "formal parameter \"%s\" is an array element", + fieldValues[0])); ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], "\" is not a simple name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "formal parameter \"%s\" is not a simple name", + fieldValues[0])); ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); @@ -767,8 +772,7 @@ TclGetFrame( return result; levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -900,8 +904,7 @@ TclObjGetFrame( return result; levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -1879,10 +1882,9 @@ InterpProcNR2( * transform to an error now. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "invoked \"", - ((result == TCL_BREAK) ? "break" : "continue"), - "\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invoked \"%s\" outside of a loop", + ((result == TCL_BREAK) ? "break" : "continue"))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; @@ -1999,8 +2001,8 @@ TclProcCompileProc( if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_AppendResult(interp, - "a precompiled script jumped interps", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "a precompiled script jumped interps", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; @@ -2932,8 +2934,8 @@ Tcl_DisassembleObjCmd( procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" isn't a procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -2982,8 +2984,8 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -3017,16 +3019,16 @@ Tcl_DisassembleObjCmd( methodBody: if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", - TclGetString(objv[3]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[3]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[3]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "body not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "METHODTYPE", NULL); return TCL_ERROR; @@ -3061,7 +3063,8 @@ Tcl_DisassembleObjCmd( if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags & TCL_BYTECODE_PRECOMPILED) { - Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "BYTECODE", NULL); return TCL_ERROR; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 8a57a91..544fb6e 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1896,7 +1896,7 @@ ZlibCmd( format = TCL_ZLIB_FORMAT_GZIP; break; default: - Tcl_AppendResult(interp, "IMPOSSIBLE", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("impossible!", -1)); return TCL_ERROR; } @@ -1910,16 +1910,16 @@ ZlibCmd( */ if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "compression may only be applied to writable channels", - NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL); return TCL_ERROR; } if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "decompression may only be applied to readable channels", - NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL); return TCL_ERROR; } @@ -1937,8 +1937,8 @@ ZlibCmd( switch ((enum pushOptions) option) { case poHeader: if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -header option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "value missing for -header option", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } @@ -1950,8 +1950,8 @@ ZlibCmd( break; case poLevel: if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -level option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "value missing for -level option", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } @@ -1967,8 +1967,8 @@ ZlibCmd( break; case poLimit: if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -limit option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "value missing for -limit option", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } @@ -1996,14 +1996,15 @@ ZlibCmd( return TCL_ERROR; badLevel: - Tcl_AppendResult(interp, "level must be 0 to 9", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); if (extraInfoStr) { Tcl_AddErrorInfo(interp, extraInfoStr); } return TCL_ERROR; badBuffer: - Tcl_AppendResult(interp, "buffer size must be 32 to 65536", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "buffer size must be 32 to 65536", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); return TCL_ERROR; } @@ -2086,9 +2087,9 @@ ZlibStreamCmd( break; case ao_buffer: /* -buffer */ if (i == objc-2) { - Tcl_AppendResult(interp, "\"-buffer\" option must be " - "followed by integer decompression buffersize", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-buffer\" option must be followed by integer" + " decompression buffersize", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } @@ -2097,8 +2098,8 @@ ZlibStreamCmd( return TCL_ERROR; } if (buffersize < 1 || buffersize > 65536) { - Tcl_AppendResult(interp, - "buffer size must be 32 to 65536", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "buffer size must be 32 to 65536", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); return TCL_ERROR; @@ -2106,8 +2107,9 @@ ZlibStreamCmd( } if (flush == -2) { - Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " - "\"-finalize\" options are mutually exclusive", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-flush\", \"-fullflush\" and \"-finalize\" options" + " are mutually exclusive", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); return TCL_ERROR; } @@ -2158,13 +2160,14 @@ ZlibStreamCmd( } break; case ao_buffer: - Tcl_AppendResult(interp, - "\"-buffer\" option not supported here", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-buffer\" option not supported here", -1)); return TCL_ERROR; } if (flush == -2) { - Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " - "\"-finalize\" options are mutually exclusive", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-flush\", \"-fullflush\" and \"-finalize\" options" + " are mutually exclusive", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); return TCL_ERROR; } @@ -2314,9 +2317,9 @@ ZlibTransformClose( * then interp may be NULL */ if (!TclInThreadExit()) { if (interp) { - Tcl_AppendResult(interp, - "error while finalizing file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error while finalizing file: %s", + Tcl_PosixError(interp))); } } result = TCL_ERROR; @@ -2611,8 +2614,9 @@ ZlibTransformSetOption( /* not used */ if (Tcl_WriteRaw(cd->parent, cd->outBuffer, cd->outStream.next_out - (Bytef *) cd->outBuffer) < 0) { - Tcl_AppendResult(interp, "problem flushing channel: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "problem flushing channel: %s", + Tcl_PosixError(interp))); return TCL_ERROR; } } diff --git a/tests/format.test b/tests/format.test index 2d53eba..27eac31 100644 --- a/tests/format.test +++ b/tests/format.test @@ -549,10 +549,7 @@ test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} { list [format %08x $a] [expr {$a == $b}] } {aaaaaaab 1} -test format-19.1 { - regression test - tcl-core message by Brian Griffin on - 26 0ctober 2004 -} -body { +test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body { set x 0x8fedc654 list [expr { ~ $x }] [format %08x [expr { ~$x }]] } -match regexp -result {-2414724693 f*701239ab} @@ -569,7 +566,7 @@ test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body { format %s $x # After this, obj in $x should be a dict with a non-NULL bytes field tcl::unsupported::representation $x -} -match glob -result {value is a dict with *, string representation "*".} +} -match glob -result {value is a dict with *, string representation "*"} # cleanup catch {unset a} -- cgit v0.12 From 3ac48032033ebb2c43a8a0184ae5f8ef0451e78c Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 4 Aug 2012 12:09:26 +0000 Subject: Reduce the amount of ifdeffery somewhat by requiring at least OSX Tiger. That's now everyone we care to support, given that the version after is now not supported by Apple... --- unix/tclLoadDyld.c | 252 +++++++++++++++++------------------------------------ 1 file changed, 78 insertions(+), 174 deletions(-) diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 31d15b2..95735a4 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -16,42 +16,36 @@ #include "tclInt.h" #ifndef MODULE_SCOPE -#define MODULE_SCOPE extern +# define MODULE_SCOPE extern #endif -#ifndef TCL_DYLD_USE_DLFCN /* * Use preferred dlfcn API on 10.4 and later */ -# if !defined(NO_DLFCN_H) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1040 -# define TCL_DYLD_USE_DLFCN 1 -# else + +#ifndef TCL_DYLD_USE_DLFCN +# ifdef NO_DLFCN_H # define TCL_DYLD_USE_DLFCN 0 +# else +# define TCL_DYLD_USE_DLFCN 1 # endif #endif -#ifndef TCL_DYLD_USE_NSMODULE + /* * Use deprecated NSModule API only to support 10.3 and earlier: */ -# if MAC_OS_X_VERSION_MIN_REQUIRED < 1040 -# define TCL_DYLD_USE_NSMODULE 1 -# else -# define TCL_DYLD_USE_NSMODULE 0 -# endif + +#ifndef TCL_DYLD_USE_NSMODULE +# define TCL_DYLD_USE_NSMODULE 0 #endif -#if TCL_DYLD_USE_DLFCN -#include -#if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040 /* - * Support for weakly importing dlfcn API. + * Use includes for the API we're using. */ -extern void *dlopen(const char *path, int mode) WEAK_IMPORT_ATTRIBUTE; -extern void *dlsym(void *handle, const char *symbol) WEAK_IMPORT_ATTRIBUTE; -extern int dlclose(void *handle) WEAK_IMPORT_ATTRIBUTE; -extern char *dlerror(void) WEAK_IMPORT_ATTRIBUTE; -#endif -#endif + +#if TCL_DYLD_USE_DLFCN +# include +#endif /* TCL_DYLD_USE_DLFCN */ #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) #include @@ -60,38 +54,23 @@ extern char *dlerror(void) WEAK_IMPORT_ATTRIBUTE; #include #include #include -#include typedef struct Tcl_DyldModuleHandle { struct Tcl_DyldModuleHandle *nextPtr; NSModule module; } Tcl_DyldModuleHandle; -#endif /* TCL_DYLD_USE_NSMODULE */ +#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */ -typedef struct Tcl_DyldLoadHandle { -#if TCL_DYLD_USE_DLFCN +typedef struct { void *dlHandle; -#endif #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) const struct mach_header *dyldLibHeader; Tcl_DyldModuleHandle *modulePtr; #endif } Tcl_DyldLoadHandle; -#if (TCL_DYLD_USE_DLFCN && MAC_OS_X_VERSION_MIN_REQUIRED < 1040) || \ - defined(TCL_LOAD_FROM_MEMORY) -MODULE_SCOPE long tclMacOSXDarwinRelease; -#endif - -#ifdef TCL_DEBUG_LOAD -#define TclLoadDbgMsg(m, ...) \ - do { \ - fprintf(stderr, "%s:%d: %s(): " m ".\n", \ - strrchr(__FILE__, '/')+1, __LINE__, __func__, \ - ##__VA_ARGS__); \ - } while (0) -#else -#define TclLoadDbgMsg(m, ...) +#if TCL_DYLD_USE_DLFCN || defined(TCL_LOAD_FROM_MEMORY) +MODULE_SCOPE long tclMacOSXDarwinRelease; #endif /* @@ -102,7 +81,6 @@ static void * FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol); static void UnloadFile(Tcl_LoadHandle handle); -#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) /* *---------------------------------------------------------------------- * @@ -120,6 +98,7 @@ static void UnloadFile(Tcl_LoadHandle handle); *---------------------------------------------------------------------- */ +#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) static const char * DyldOFIErrorMsg( int err) @@ -141,7 +120,7 @@ DyldOFIErrorMsg( return "unknown error"; } } -#endif /* TCL_DYLD_USE_NSMODULE */ +#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */ /* *---------------------------------------------------------------------- @@ -176,9 +155,7 @@ TclpDlopen( { Tcl_DyldLoadHandle *dyldLoadHandle; Tcl_LoadHandle newHandle; -#if TCL_DYLD_USE_DLFCN void *dlHandle = NULL; -#endif #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) const struct mach_header *dyldLibHeader = NULL; Tcl_DyldModuleHandle *modulePtr = NULL; @@ -187,11 +164,10 @@ TclpDlopen( NSLinkEditErrors editError; int errorNumber; const char *errorName, *objFileImageErrMsg = NULL; -#endif +#endif /* TCL_DYLD_USE_NSMODULE */ const char *errMsg = NULL; int result; Tcl_DString ds; - char *fileName = NULL; const char *nativePath, *nativeFileName = NULL; /* @@ -201,46 +177,36 @@ TclpDlopen( */ nativePath = Tcl_FSGetNativePath(pathPtr); + nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), + -1, &ds); #if TCL_DYLD_USE_DLFCN -#if MAC_OS_X_VERSION_MIN_REQUIRED < 1040 - if (tclMacOSXDarwinRelease >= 8) -#endif - { /* * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070] */ - dlHandle = dlopen(nativePath, RTLD_NOW | RTLD_LOCAL); - if (!dlHandle) { - /* - * Let the OS loader examine the binary search path for whatever - * string the user gave us which hopefully refers to a file on the - * binary path. - */ - fileName = Tcl_GetString(pathPtr); - nativeFileName = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); - /* - * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070] - */ - dlHandle = dlopen(nativeFileName, RTLD_NOW | RTLD_LOCAL); - } - if (dlHandle) { - TclLoadDbgMsg("dlopen() successful"); - } else { + dlHandle = dlopen(nativePath, RTLD_NOW | RTLD_LOCAL); + if (!dlHandle) { + /* + * Let the OS loader examine the binary search path for whatever string + * the user gave us which hopefully refers to a file on the binary + * path. + * + * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070] + */ + + dlHandle = dlopen(nativeFileName, RTLD_NOW | RTLD_LOCAL); + if (!dlHandle) { errMsg = dlerror(); - TclLoadDbgMsg("dlopen() failed: %s", errMsg); } } - if (!dlHandle) #endif /* TCL_DYLD_USE_DLFCN */ - { + + if (!dlHandle) { #if TCL_DYLD_USE_NSMODULE dyldLibHeader = NSAddImage(nativePath, NSADDIMAGE_OPTION_RETURN_ON_ERROR); - if (dyldLibHeader) { - TclLoadDbgMsg("NSAddImage() successful"); - } else { + if (!dyldLibHeader) { NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); if (editError == NSLinkEditFileAccessError) { /* @@ -249,20 +215,12 @@ TclpDlopen( * which hopefully refers to a file on the binary path. */ - if (!fileName) { - fileName = Tcl_GetString(pathPtr); - nativeFileName = Tcl_UtfToExternalDString(NULL, fileName, - -1, &ds); - } dyldLibHeader = NSAddImage(nativeFileName, NSADDIMAGE_OPTION_WITH_SEARCHING | NSADDIMAGE_OPTION_RETURN_ON_ERROR); - if (dyldLibHeader) { - TclLoadDbgMsg("NSAddImage() successful"); - } else { + if (!dyldLibHeader) { NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); - TclLoadDbgMsg("NSAddImage() failed: %s", errMsg); } } else if ((editError == NSLinkEditFileFormatError && errorNumber == EBADMACHO) @@ -279,8 +237,6 @@ TclpDlopen( err = NSCreateObjectFileImageFromFile(nativePath, &dyldObjFileImage); if (err == NSObjectFileImageSuccess && dyldObjFileImage) { - TclLoadDbgMsg("NSCreateObjectFileImageFromFile() " - "successful"); module = NSLinkModule(dyldObjFileImage, nativePath, NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_RETURN_ON_ERROR); @@ -289,37 +245,29 @@ TclpDlopen( modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = NULL; - TclLoadDbgMsg("NSLinkModule() successful"); } else { NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); - TclLoadDbgMsg("NSLinkModule() failed: %s", errMsg); } } else { objFileImageErrMsg = DyldOFIErrorMsg(err); - TclLoadDbgMsg("NSCreateObjectFileImageFromFile() failed: " - "%s", objFileImageErrMsg); } } } #endif /* TCL_DYLD_USE_NSMODULE */ } - if (0 -#if TCL_DYLD_USE_DLFCN - || dlHandle -#endif + + if (dlHandle #if TCL_DYLD_USE_NSMODULE || dyldLibHeader || modulePtr -#endif +#endif /* TCL_DYLD_USE_NSMODULE */ ) { dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle)); -#if TCL_DYLD_USE_DLFCN dyldLoadHandle->dlHandle = dlHandle; -#endif #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) dyldLoadHandle->dyldLibHeader = dyldLibHeader; dyldLoadHandle->modulePtr = modulePtr; -#endif +#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */ newHandle = ckalloc(sizeof(*newHandle)); newHandle->clientData = dyldLoadHandle; newHandle->findSymbolProcPtr = &FindSymbol; @@ -328,18 +276,23 @@ TclpDlopen( *loadHandle = newHandle; result = TCL_OK; } else { - Tcl_AppendResult(interp, errMsg, NULL); + Tcl_Obj *errObj = Tcl_NewObj(); + + if (errMsg != NULL) { + Tcl_AppendToObj(errObj, errMsg, -1); + } #if TCL_DYLD_USE_NSMODULE if (objFileImageErrMsg) { - Tcl_AppendResult(interp, "\nNSCreateObjectFileImageFromFile() " - "error: ", objFileImageErrMsg, NULL); + Tcl_AppendPrintfToObj(errObj, + "\nNSCreateObjectFileImageFromFile() error: %s", + objFileImageErrMsg); } -#endif +#endif /* TCL_DYLD_USE_NSMODULE */ + Tcl_SetObjResult(interp, errObj); result = TCL_ERROR; } - if(fileName) { - Tcl_DStringFree(&ds); - } + + Tcl_DStringFree(&ds); return result; } @@ -372,18 +325,14 @@ FindSymbol( const char *native; native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); -#if TCL_DYLD_USE_DLFCN if (dyldLoadHandle->dlHandle) { +#if TCL_DYLD_USE_DLFCN proc = dlsym(dyldLoadHandle->dlHandle, native); - if (proc) { - TclLoadDbgMsg("dlsym() successful"); - } else { + if (!proc) { errMsg = dlerror(); - TclLoadDbgMsg("dlsym() failed: %s", errMsg); } - } else #endif /* TCL_DYLD_USE_DLFCN */ - { + } else { #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) NSSymbol nsSymbol = NULL; Tcl_DString newName; @@ -400,13 +349,12 @@ FindSymbol( native, NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR); if (nsSymbol) { - TclLoadDbgMsg("NSLookupSymbolInImage() successful"); -#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING /* * Until dyld supports unloading of MY_DYLIB binaries, the * following is not needed. */ +#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING NSModule module = NSModuleForSymbol(nsSymbol); Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr; @@ -429,32 +377,21 @@ FindSymbol( const char *errorName; NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); - TclLoadDbgMsg("NSLookupSymbolInImage() failed: %s", errMsg); } } else if (dyldLoadHandle->modulePtr) { nsSymbol = NSLookupSymbolInModule( dyldLoadHandle->modulePtr->module, native); - if (nsSymbol) { - TclLoadDbgMsg("NSLookupSymbolInModule() successful"); - } else { - TclLoadDbgMsg("NSLookupSymbolInModule() failed"); - } } if (nsSymbol) { proc = NSAddressOfSymbol(nsSymbol); - if (proc) { - TclLoadDbgMsg("NSAddressOfSymbol() successful"); - } else { - TclLoadDbgMsg("NSAddressOfSymbol() failed"); - } } Tcl_DStringFree(&newName); #endif /* TCL_DYLD_USE_NSMODULE */ } Tcl_DStringFree(&ds); if (errMsg && (interp != NULL)) { - Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\": ", - errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\": %s", symbol, errMsg)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } @@ -489,34 +426,19 @@ UnloadFile( { Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData; -#if TCL_DYLD_USE_DLFCN if (dyldLoadHandle->dlHandle) { - int result; - - result = dlclose(dyldLoadHandle->dlHandle); - if (!result) { - TclLoadDbgMsg("dlclose() successful"); - } else { - TclLoadDbgMsg("dlclose() failed: %s", dlerror()); - } - } else +#if TCL_DYLD_USE_DLFCN + (void) dlclose(dyldLoadHandle->dlHandle); #endif /* TCL_DYLD_USE_DLFCN */ - { + } else { #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr; while (modulePtr != NULL) { - void *ptr; - bool result; + void *ptr = modulePtr; - result = NSUnLinkModule(modulePtr->module, + (void) NSUnLinkModule(modulePtr->module, NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES); - if (result) { - TclLoadDbgMsg("NSUnLinkModule() successful"); - } else { - TclLoadDbgMsg("NSUnLinkModule() failed"); - } - ptr = modulePtr; modulePtr = modulePtr->nextPtr; ckfree(ptr); } @@ -556,7 +478,6 @@ TclGuessPackageName( return 0; } -#ifdef TCL_LOAD_FROM_MEMORY /* *---------------------------------------------------------------------- * @@ -573,6 +494,7 @@ TclGuessPackageName( *---------------------------------------------------------------------- */ +#ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE void * TclpLoadMemoryGetBuffer( Tcl_Interp *interp, /* Used for error reporting. */ @@ -597,6 +519,7 @@ TclpLoadMemoryGetBuffer( } return buffer; } +#endif /* TCL_LOAD_FROM_MEMORY */ /* *---------------------------------------------------------------------- @@ -616,6 +539,7 @@ TclpLoadMemoryGetBuffer( *---------------------------------------------------------------------- */ +#ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE int TclpLoadMemory( Tcl_Interp *interp, /* Used for error reporting. */ @@ -658,7 +582,7 @@ TclpLoadMemory( # define mh_size sizeof(struct mach_header_64) # define mh_magic MH_MAGIC_64 # define arch_abi CPU_ARCH_ABI64 -#endif +#endif /* __LP64__ */ if ((size_t) codeSize >= sizeof(struct fat_header) && fh->magic == OSSwapHostToBigInt32(FAT_MAGIC)) { @@ -668,7 +592,6 @@ TclpLoadMemory( * Fat binary, try to find mach_header for our architecture */ - TclLoadDbgMsg("Fat binary, %d archs", fh_nfat_arch); if ((size_t) codeSize >= sizeof(struct fat_header) + fh_nfat_arch * sizeof(struct fat_arch)) { void *fatarchs = (char*)buffer + sizeof(struct fat_header); @@ -681,22 +604,15 @@ TclpLoadMemory( fa = NXFindBestFatArch(arch->cputype | arch_abi, arch->cpusubtype, fatarchs, fh_nfat_arch); if (fa) { - TclLoadDbgMsg("NXFindBestFatArch() successful: " - "local cputype %d subtype %d, " - "fat cputype %d subtype %d", - arch->cputype | arch_abi, arch->cpusubtype, - fa->cputype, fa->cpusubtype); - mh = (void*)((char*)buffer + fa->offset); + mh = (void *)((char *) buffer + fa->offset); ms = fa->size; } else { - TclLoadDbgMsg("NXFindBestFatArch() failed"); err = NSObjectFileImageInappropriateFile; } if (fh->magic != FAT_MAGIC) { swap_fat_arch(fatarchs, fh_nfat_arch, arch->byteorder); } } else { - TclLoadDbgMsg("Fat binary header failure"); err = NSObjectFileImageInappropriateFile; } } else { @@ -704,26 +620,18 @@ TclpLoadMemory( * Thin binary */ - TclLoadDbgMsg("Thin binary"); mh = buffer; ms = codeSize; } if (ms && !(ms >= mh_size && mh->magic == mh_magic && mh->filetype == MH_BUNDLE)) { - TclLoadDbgMsg("Inappropriate file: magic %x filetype %d", - mh->magic, mh->filetype); err = NSObjectFileImageInappropriateFile; } if (err == NSObjectFileImageSuccess) { err = NSCreateObjectFileImageFromMemory(buffer, codeSize, &dyldObjFileImage); - if (err == NSObjectFileImageSuccess) { - TclLoadDbgMsg("NSCreateObjectFileImageFromMemory() " - "successful"); - } else { + if (err != NSObjectFileImageSuccess) { objFileImageErrMsg = DyldOFIErrorMsg(err); - TclLoadDbgMsg("NSCreateObjectFileImageFromMemory() failed: %s", - objFileImageErrMsg); } } else { objFileImageErrMsg = DyldOFIErrorMsg(err); @@ -738,8 +646,9 @@ TclpLoadMemory( if (dyldObjFileImage == NULL) { vm_deallocate(mach_task_self(), (vm_address_t) buffer, size); if (objFileImageErrMsg != NULL) { - Tcl_AppendResult(interp, "NSCreateObjectFileImageFromMemory() " - "error: ", objFileImageErrMsg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "NSCreateObjectFileImageFromMemory() error: ", + objFileImageErrMsg)); } return TCL_ERROR; } @@ -751,16 +660,13 @@ TclpLoadMemory( module = NSLinkModule(dyldObjFileImage, "[Memory Based Bundle]", NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_RETURN_ON_ERROR); NSDestroyObjectFileImage(dyldObjFileImage); - if (module) { - TclLoadDbgMsg("NSLinkModule() successful"); - } else { + if (!module) { NSLinkEditErrors editError; int errorNumber; const char *errorName, *errMsg; NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); - TclLoadDbgMsg("NSLinkModule() failed: %s", errMsg); - Tcl_AppendResult(interp, errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); return TCL_ERROR; } @@ -772,9 +678,7 @@ TclpLoadMemory( modulePtr->module = module; modulePtr->nextPtr = NULL; dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle)); -#if TCL_DYLD_USE_DLFCN dyldLoadHandle->dlHandle = NULL; -#endif dyldLoadHandle->dyldLibHeader = NULL; dyldLoadHandle->modulePtr = modulePtr; newHandle = ckalloc(sizeof(*newHandle)); -- cgit v0.12 From b8d984dbc886ed27c8607c95a05ee1172e2cc5d0 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 4 Aug 2012 13:04:41 +0000 Subject: more result generation conversion --- unix/tclLoadDl.c | 10 +++++----- unix/tclLoadNext.c | 27 +++++++++++++-------------- unix/tclLoadOSF.c | 12 +++++++----- unix/tclLoadShl.c | 11 ++++++----- win/tclWinLoad.c | 34 ++++++++++++++++++---------------- 5 files changed, 49 insertions(+), 45 deletions(-) diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index d86e7fd..4f9c6b8 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -112,8 +112,9 @@ TclpDlopen( const char *errorStr = dlerror(); - Tcl_AppendResult(interp, "couldn't load file \"", - Tcl_GetString(pathPtr), "\": ", errorStr, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load file \"%s\": %s", + Tcl_GetString(pathPtr), errorStr)); return TCL_ERROR; } newHandle = ckalloc(sizeof(*newHandle)); @@ -175,9 +176,8 @@ FindSymbol( } Tcl_DStringFree(&ds); if (proc == NULL && interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\": ", - dlerror(), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\": %s", symbol, dlerror()); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index c74a29a..06df2db 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -16,10 +16,9 @@ /* Static procedures defined within this file */ -static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, - const char* symbol); -static void UnloadFile(Tcl_LoadHandle loadHandle); - +static void * FindSymbol(Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, const char* symbol); +static void UnloadFile(Tcl_LoadHandle loadHandle); /* *---------------------------------------------------------------------- @@ -93,15 +92,15 @@ TclpDlopen( char *data; int len, maxlen; - NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); - Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", - data, NULL); + NXGetMemoryBuffer(errorStream, &data, &len, &maxlen); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load file \"%s\": %s", fileName, data)); NXCloseMemory(errorStream, NX_FREEBUFFER); return TCL_ERROR; } NXCloseMemory(errorStream, NX_FREEBUFFER); - newHandle = ckalloc(sizeof(*newHandle)); + newHandle = ckalloc(sizeof(Tcl_LoadHandle)); newHandle->clientData = INT2PTR(1); newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; @@ -127,25 +126,25 @@ TclpDlopen( *---------------------------------------------------------------------- */ -static void* +static void * FindSymbol( Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol) { Tcl_PackageInitProc *proc = NULL; - if (symbol) { + + if (symbol) { char sym[strlen(symbol) + 2]; sym[0] = '_'; sym[1] = 0; strcat(sym, symbol); - rld_lookup(NULL, sym, (unsigned long *)&proc); + rld_lookup(NULL, sym, (unsigned long *) &proc); } if (proc == NULL && interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot find symbol \"", symbol, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\"", symbol)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } return proc; diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index fbd4d5f..6515b89 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -103,8 +103,9 @@ TclpDlopen( } if (lm == LDR_NULL_MODULE) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load file \"%s\": %s", + fileName, Tcl_PosixError(interp)); return TCL_ERROR; } @@ -155,10 +156,11 @@ FindSymbol( Tcl_LoadHandle loadHandle, const char *symbol) { - void* retval = ldr_lookup_package((char *)loadHandle, symbol); + void *retval = ldr_lookup_package((char *) loadHandle, symbol); + if (retval == NULL && interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot find symbol\"", symbol, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\"", symbol)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } return retval; diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index eddd80a..968f232 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -100,8 +100,9 @@ TclpDlopen( } if (handle == NULL) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load file \"%s\": %s", + fileName, Tcl_PosixError(interp))); return TCL_ERROR; } newHandle = ckalloc(sizeof(*newHandle)); @@ -155,9 +156,9 @@ FindSymbol( Tcl_DStringFree(&newName); } if (proc == NULL && interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot find symbol\"", symbol, "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\": %s", + symbol, Tcl_PosixError(interp))); } return proc; } diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index b59ccba..6294086 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -91,9 +91,8 @@ TclpDlopen( if (hInstance == NULL) { DWORD lastError = GetLastError(); - - Tcl_AppendResult(interp, "couldn't load library \"", - Tcl_GetString(pathPtr), "\": ", NULL); + Tcl_Obj *errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", + Tcl_GetString(pathPtr)); /* * Check for possible DLL errors. This doesn't work quite right, @@ -109,29 +108,30 @@ TclpDlopen( case ERROR_DLL_NOT_FOUND: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL); notFoundMsg: - Tcl_AppendResult(interp, "this library or a dependent library" - " could not be found in library path", NULL); + Tcl_AppendToObj(errMsg, "this library or a dependent library" + " could not be found in library path", -1); break; case ERROR_PROC_NOT_FOUND: Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL); - Tcl_AppendResult(interp, "A function specified in the import" - " table could not be resolved by the system. Windows" - " is not telling which one, I'm sorry.", NULL); + Tcl_AppendToObj(errMsg, "A function specified in the import" + " table could not be resolved by the system. Windows" + " is not telling which one, I'm sorry.", -1); break; case ERROR_INVALID_DLL: Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL); - Tcl_AppendResult(interp, "this library or a dependent library" - " is damaged", NULL); + Tcl_AppendToObj(errMsg, "this library or a dependent library" + " is damaged", -1); break; case ERROR_DLL_INIT_FAILED: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); - Tcl_AppendResult(interp, "the library initialization" - " routine failed", NULL); + Tcl_AppendToObj(errMsg, "the library initialization" + " routine failed", -1); break; default: TclWinConvertError(lastError); - Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); + Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1); } + Tcl_SetObjResult(interp, errMsg); return TCL_ERROR; } @@ -190,7 +190,8 @@ FindSymbol( Tcl_DStringFree(&ds); } if (proc == NULL && interp != NULL) { - Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\"", symbol)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } return proc; @@ -286,8 +287,9 @@ TclpTempFileNameForLibrary( Tcl_MutexLock(&dllDirectoryNameMutex); if (dllDirectoryName == NULL) { if (InitDLLDirectoryName() == TCL_ERROR) { - Tcl_AppendResult(interp, "couldn't create temporary directory: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create temporary directory: %s", + Tcl_PosixError(interp))); Tcl_MutexUnlock(&dllDirectoryNameMutex); return NULL; } -- cgit v0.12 From d8bae8d8c160bda642defb70d49448aadd1b6068 Mon Sep 17 00:00:00 2001 From: stwo Date: Sat, 4 Aug 2012 18:54:45 +0000 Subject: Unbreak. --- unix/tclLoadDl.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 4f9c6b8..f8fe6d3 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -177,7 +177,7 @@ FindSymbol( Tcl_DStringFree(&ds); if (proc == NULL && interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "cannot find symbol \"%s\": %s", symbol, dlerror()); + "cannot find symbol \"%s\": %s", symbol, dlerror())); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } -- cgit v0.12 From 13147008eb79f31b7f144a848233b4a28591b2d9 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 5 Aug 2012 12:09:12 +0000 Subject: Final part of result generation conversion (modulo any minor blunders) --- generic/tclIO.c | 125 +++++++++++++++++++++------------------- generic/tclIOCmd.c | 152 +++++++++++++++++++++++++------------------------ generic/tclIOGT.c | 4 +- generic/tclIORChan.c | 129 ++++++++++++++++++++++------------------- generic/tclIORTrans.c | 111 +++++++++++++++++++----------------- generic/tclIOSock.c | 36 ++++++------ generic/tclIOUtil.c | 102 ++++++++++++++++++--------------- macosx/tclMacOSXFCmd.c | 57 ++++++++++--------- unix/tclUnixChan.c | 75 ++++++++++++------------ unix/tclUnixFCmd.c | 81 +++++++++++++------------- unix/tclUnixFile.c | 13 ++--- unix/tclUnixPipe.c | 64 +++++++++++---------- unix/tclUnixSock.c | 146 +++++++++++++++++++++++++---------------------- win/tclWinChan.c | 16 +++--- win/tclWinDde.c | 7 ++- win/tclWinFCmd.c | 16 +++--- win/tclWinFile.c | 12 ++-- win/tclWinPipe.c | 37 ++++++------ win/tclWinReg.c | 33 +++++------ win/tclWinSerial.c | 143 ++++++++++++++++++++-------------------------- win/tclWinSock.c | 42 +++++++------- 21 files changed, 730 insertions(+), 671 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 2de8b53..4e24533 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1027,8 +1027,9 @@ Tcl_UnregisterChannel( if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp != NULL) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -1263,8 +1264,8 @@ Tcl_GetChannel( hTblPtr = GetChannelTable(interp); hPtr = Tcl_FindHashEntry(hTblPtr, name); if (hPtr == NULL) { - Tcl_AppendResult(interp, "can not find channel named \"", chanName, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can not find channel named \"%s\"", chanName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanName, NULL); return NULL; } @@ -1584,8 +1585,9 @@ Tcl_StackChannel( if (statePtr == NULL) { if (interp) { - Tcl_AppendResult(interp, "couldn't find state for channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find state for channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1605,9 +1607,9 @@ Tcl_StackChannel( if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) { if (interp) { - Tcl_AppendResult(interp, - "reading and writing both disallowed for channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "reading and writing both disallowed for channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1630,8 +1632,9 @@ Tcl_StackChannel( statePtr->csPtrR = csPtrR; statePtr->csPtrW = csPtrW; if (interp) { - Tcl_AppendResult(interp, "could not flush channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not flush channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1784,9 +1787,9 @@ Tcl_UnstackChannel( */ if (!TclChanCaughtErrorBypass(interp, chan) && interp) { - Tcl_AppendResult(interp, "could not flush channel \"", - Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not flush channel \"%s\"", + Tcl_GetChannelName((Tcl_Channel) chanPtr))); } return TCL_ERROR; } @@ -2318,8 +2321,8 @@ CheckForDeadChannel( Tcl_SetErrno(EINVAL); if (interp) { - Tcl_AppendResult(interp, "unable to access channel: invalid channel", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to access channel: invalid channel", -1)); } return 1; } @@ -3051,8 +3054,9 @@ Tcl_Close( if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -3210,8 +3214,9 @@ Tcl_CloseEx( */ if (!chanPtr->typePtr->close2Proc) { - Tcl_AppendResult(interp, "Half-close of channels not supported by ", - chanPtr->typePtr->typeName, "s", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "half-close of channels not supported by %ss", + chanPtr->typePtr->typeName)); return TCL_ERROR; } @@ -3220,9 +3225,8 @@ Tcl_CloseEx( */ if (chanPtr != statePtr->topChanPtr) { - Tcl_AppendResult(interp, - "Half-close not applicable to stack of transformations", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "half-close not applicable to stack of transformations", -1)); return TCL_ERROR; } @@ -3240,9 +3244,9 @@ Tcl_CloseEx( } else { msg = "write"; } - Tcl_AppendResult(interp, "Half-close of ", msg, - "-side not possible, side not opened or already closed", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Half-close of %s-side not possible, side not opened or" + " already closed", msg)); return TCL_ERROR; } @@ -3253,8 +3257,9 @@ Tcl_CloseEx( if (statePtr->flags & CHANNEL_INCLOSE) { if (interp) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -7547,6 +7552,7 @@ Tcl_BadChannelOption( const char **argv; int argc, i; Tcl_DString ds; + Tcl_Obj *errObj; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, genericopt, -1); @@ -7559,13 +7565,14 @@ Tcl_BadChannelOption( Tcl_Panic("malformed option list in channel driver"); } Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad option \"", optionName, - "\": should be one of ", NULL); + errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ", + optionName); argc--; for (i = 0; i < argc; i++) { - Tcl_AppendResult(interp, "-", argv[i], ", ", NULL); + Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]); } - Tcl_AppendResult(interp, "or -", argv[i], NULL); + Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]); + Tcl_SetObjResult(interp, errObj); Tcl_DStringFree(&ds); ckfree(argv); } @@ -7843,8 +7850,9 @@ Tcl_SetChannelOption( if (statePtr->csPtrR || statePtr->csPtrW) { if (interp) { - Tcl_AppendResult(interp, "unable to set channel options: " - "background copy in progress", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to set channel options: background copy in" + " progress", -1)); } return TCL_ERROR; } @@ -7893,8 +7901,9 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_LINEBUFFERED); SetFlag(statePtr, CHANNEL_UNBUFFERED); } else if (interp) { - Tcl_AppendResult(interp, "bad value for -buffering: " - "must be one of full, line, or none", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -buffering: must be one of" + " full, line, or none", -1)); return TCL_ERROR; } return TCL_OK; @@ -7949,8 +7958,9 @@ Tcl_SetChannelOption( if (inValue & 0x80 || outValue & 0x80) { if (interp) { - Tcl_AppendResult(interp, "bad value for -eofchar: ", - "must be non-NUL ASCII character", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -eofchar: must be non-NUL ASCII" + " character", -1)); } ckfree(argv); return TCL_ERROR; @@ -7963,9 +7973,9 @@ Tcl_SetChannelOption( } } else { if (interp) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -eofchar: should be a list of zero," - " one, or two elements", NULL); + " one, or two elements", -1)); } ckfree(argv); return TCL_ERROR; @@ -7997,9 +8007,9 @@ Tcl_SetChannelOption( writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL; } else { if (interp) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be a one or two" - " element list", NULL); + " element list", -1)); } ckfree(argv); return TCL_ERROR; @@ -8027,10 +8037,9 @@ Tcl_SetChannelOption( translation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { - Tcl_AppendResult(interp, - "bad value for -translation: " - "must be one of auto, binary, cr, lf, crlf," - " or platform", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -translation: must be one of " + "auto, binary, cr, lf, crlf, or platform", -1)); } ckfree(argv); return TCL_ERROR; @@ -8078,10 +8087,9 @@ Tcl_SetChannelOption( statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { - Tcl_AppendResult(interp, - "bad value for -translation: " - "must be one of auto, binary, cr, lf, crlf," - " or platform", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -translation: must be one of " + "auto, binary, cr, lf, crlf, or platform", -1)); } ckfree(argv); return TCL_ERROR; @@ -8901,8 +8909,8 @@ Tcl_FileEventObjCmd( chanPtr = (Channel *) chan; statePtr = chanPtr->state; if ((statePtr->flags & mask) == 0) { - Tcl_AppendResult(interp, "channel is not ", - (mask == TCL_READABLE) ? "readable" : "writable", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s", + (mask == TCL_READABLE) ? "readable" : "writable")); return TCL_ERROR; } @@ -9023,15 +9031,15 @@ TclCopyChannel( if (BUSY_STATE(inStatePtr, TCL_READABLE)) { if (interp) { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(inChan), "\" is busy", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" is busy", Tcl_GetChannelName(inChan))); } return TCL_ERROR; } if (BUSY_STATE(outStatePtr, TCL_WRITABLE)) { if (interp) { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(outChan), "\" is busy", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" is busy", Tcl_GetChannelName(outChan))); } return TCL_ERROR; } @@ -10157,8 +10165,9 @@ SetBlockMode( */ if (!TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) { - Tcl_AppendResult(interp, "error setting blocking mode: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error setting blocking mode: %s", + Tcl_PosixError(interp))); } } else { /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 59856d0..005713d 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -174,9 +174,10 @@ Tcl_PutsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -201,8 +202,8 @@ Tcl_PutsObjCmd( error: if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error writing \"", TclGetString(chanObjPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -244,9 +245,10 @@ Tcl_FlushObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -259,9 +261,9 @@ Tcl_FlushObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error flushing \"", - TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error flushing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -306,9 +308,10 @@ Tcl_GetsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -326,10 +329,9 @@ Tcl_GetsObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -411,9 +413,10 @@ Tcl_ReadObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(chanObjPtr))); return TCL_ERROR; } i++; /* Consumed channel name. */ @@ -436,11 +439,11 @@ Tcl_ReadObjCmd( if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { #endif - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected non-negative integer but got \"", - TclGetString(objv[i]), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected non-negative integer but got \"%s\"", + TclGetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + return TCL_ERROR; #if TCL_MAJOR_VERSION < 9 } newline = 1; @@ -460,10 +463,9 @@ Tcl_ReadObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; @@ -552,9 +554,9 @@ Tcl_SeekObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error during seek on \"", - TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during seek on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -679,9 +681,9 @@ Tcl_CloseObjCmd( */ if (!(dir & Tcl_GetChannelMode(chan))) { - Tcl_AppendResult(interp, "Half-close of ", dirOptions[index], - "-side not possible, side not opened or already closed", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Half-close of %s-side not possible, side not opened" + " or already closed", dirOptions[index])); return TCL_ERROR; } @@ -977,9 +979,9 @@ Tcl_ExecObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading output from command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading output from command: %s", + Tcl_PosixError(interp))); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; @@ -1048,9 +1050,10 @@ Tcl_FblockedObjCmd( if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(objv[1]))); return TCL_ERROR; } @@ -1174,7 +1177,7 @@ Tcl_OpenObjCmd( return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } @@ -1479,8 +1482,8 @@ Tcl_SocketObjCmd( switch ((enum socketOptions) optionIndex) { case SKT_ASYNC: if (server == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot set -async option for server sockets", -1)); return TCL_ERROR; } async = 1; @@ -1488,8 +1491,8 @@ Tcl_SocketObjCmd( case SKT_MYADDR: a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myaddr option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myaddr option", -1)); return TCL_ERROR; } myaddr = TclGetString(objv[a]); @@ -1499,8 +1502,8 @@ Tcl_SocketObjCmd( a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myport option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myport option", -1)); return TCL_ERROR; } myPortName = TclGetString(objv[a]); @@ -1511,15 +1514,15 @@ Tcl_SocketObjCmd( } case SKT_SERVER: if (async == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot set -async option for server sockets", -1)); return TCL_ERROR; } server = 1; a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -server option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -server option", -1)); return TCL_ERROR; } script = TclGetString(objv[a]); @@ -1531,8 +1534,8 @@ Tcl_SocketObjCmd( if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { - Tcl_AppendResult(interp, "option -myport is not valid for servers", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -myport is not valid for servers", -1)); return TCL_ERROR; } } else if (a < objc) { @@ -1599,9 +1602,9 @@ Tcl_SocketObjCmd( return TCL_ERROR; } } - Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_RegisterChannel(interp, chan); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } @@ -1651,17 +1654,19 @@ Tcl_FcopyObjCmd( if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(objv[1]))); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(objv[2]))); return TCL_ERROR; } @@ -1745,14 +1750,14 @@ ChanPendingObjCmd( switch ((enum options) index) { case PENDING_INPUT: - if ((mode & TCL_READABLE) == 0) { + if (!(mode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); } break; case PENDING_OUTPUT: - if ((mode & TCL_WRITABLE) == 0) { + if (!(mode & TCL_WRITABLE)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); @@ -1806,8 +1811,8 @@ ChanTruncateObjCmd( return TCL_ERROR; } if (length < 0) { - Tcl_AppendResult(interp, - "cannot truncate to negative length of file", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot truncate to negative length of file", -1)); return TCL_ERROR; } } else { @@ -1817,18 +1822,17 @@ ChanTruncateObjCmd( length = Tcl_Tell(chan); if (length == Tcl_WideAsLong(-1)) { - Tcl_AppendResult(interp, - "could not determine current location in \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not determine current location in \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } } if (Tcl_TruncateChannel(chan, length) != TCL_OK) { - Tcl_AppendResult(interp, "error during truncate on \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during truncate on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 6f80c25..bfe6a10 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -284,8 +284,8 @@ TclChannelTransform( dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr, mode, chan); if (dataPtr->self == NULL) { - Tcl_AppendResult(interp, "\nfailed to stack channel \"", - Tcl_GetChannelName(chan), "\"", NULL); + Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), + "\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan)); Tcl_DecrRefCount(dataPtr->command); ResultClear(&dataPtr->result); ckfree(dataPtr); diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index eeb11f9..a354d60 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -404,25 +404,25 @@ static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ - if ((p)->base.mustFree) { \ - ckfree((p)->base.msgStr); \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ } #define PassReceivedErrorInterp(i,p) \ - if ((i) != NULL) { \ - Tcl_SetChannelErrorInterp((i), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - } \ + if ((i) != NULL) { \ + Tcl_SetChannelErrorInterp((i), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + } \ FreeReceivedError(p) #define PassReceivedError(c,p) \ Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ FreeReceivedError(p) #define ForwardSetStaticError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 0; \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 0; \ (p)->base.msgStr = (char *) (emsg) #define ForwardSetDynamicError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 1; \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 1; \ (p)->base.msgStr = (char *) (emsg) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); @@ -775,13 +775,15 @@ TclChanCreateObjCmd( */ typedef struct ReflectEvent { - Tcl_Event header; - ReflectedChannel* rcPtr; - int events; + Tcl_Event header; + ReflectedChannel *rcPtr; + int events; } ReflectEvent; static int -ReflectEventRun (Tcl_Event* ev, int flags) +ReflectEventRun( + Tcl_Event *ev, + int flags) { /* OWNER thread * @@ -790,14 +792,16 @@ ReflectEventRun (Tcl_Event* ev, int flags) * accomplishing that. */ - ReflectEvent* e = (ReflectEvent*) ev; + ReflectEvent *e = (ReflectEvent *) ev; - Tcl_NotifyChannel (e->rcPtr->chan, e->events); + Tcl_NotifyChannel(e->rcPtr->chan, e->events); return 1; } static int -ReflectEventDelete (Tcl_Event* ev, ClientData cd) +ReflectEventDelete( + Tcl_Event *ev, + ClientData cd) { /* OWNER thread * @@ -806,11 +810,9 @@ ReflectEventDelete (Tcl_Event* ev, ClientData cd) * invalid channel. */ - ReflectEvent* e = (ReflectEvent*) ev; + ReflectEvent *e = (ReflectEvent *) ev; - if ((ev->proc != ReflectEventRun) || - ((cd != NULL) && - (cd != e->rcPtr))) { + if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) { return 0; } return 1; @@ -868,8 +870,8 @@ TclChanPostEventObjCmd( hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId); if (hPtr == NULL) { - Tcl_AppendResult(interp, "can not find reflected channel named \"", - chanId, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can not find reflected channel named \"%s\"", chanId)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL); return TCL_ERROR; } @@ -926,8 +928,9 @@ TclChanPostEventObjCmd( */ if (events & ~rcPtr->interest) { - Tcl_AppendResult(interp, "tried to post events channel \"", chanId, - "\" is not interested in", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "tried to post events channel \"%s\" is not interested in", + chanId)); return TCL_ERROR; } @@ -938,10 +941,11 @@ TclChanPostEventObjCmd( #ifdef TCL_THREADS if (rcPtr->owner == rcPtr->thread) { #endif - Tcl_NotifyChannel (chan, events); + Tcl_NotifyChannel(chan, events); #ifdef TCL_THREADS } else { - ReflectEvent* ev = ckalloc (sizeof (ReflectEvent)); + ReflectEvent *ev = ckalloc(sizeof(ReflectEvent)); + ev->header.proc = ReflectEventRun; ev->events = events; ev->rcPtr = rcPtr; @@ -958,7 +962,8 @@ TclChanPostEventObjCmd( * The teardown of unprocessed events is currently coupled to the * thread reflected channel map */ - (void) GetThreadReflectedChannelMap (); + + (void) GetThreadReflectedChannelMap(); /* XXX Race condition !! * XXX The destination thread may not exist anymore already. @@ -966,8 +971,9 @@ TclChanPostEventObjCmd( * XXX Can we detect this ? (check the validity of the owner threadid ?) * XXX Actually, in that case the channel should be dead also ! */ - Tcl_ThreadQueueEvent (rcPtr->owner, (Tcl_Event*) ev, TCL_QUEUE_TAIL); - Tcl_ThreadAlert (rcPtr->owner); + + Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL); + Tcl_ThreadAlert(rcPtr->owner); } #endif @@ -1157,8 +1163,11 @@ ReflectClose( ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* Now squash the pending reflection events for this channel. */ - Tcl_DeleteEvents (ReflectEventDelete, rcPtr); + /* + * Now squash the pending reflection events for this channel. + */ + + Tcl_DeleteEvents(ReflectEventDelete, rcPtr); if (result != TCL_OK) { FreeReceivedError(&p); @@ -1166,7 +1175,7 @@ ReflectClose( } #endif - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1178,7 +1187,7 @@ ReflectClose( */ if (rcPtr->methods == 0) { - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1193,10 +1202,13 @@ ReflectClose( ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* Now squash the pending reflection events for this channel. */ - Tcl_DeleteEvents (ReflectEventDelete, rcPtr); + /* + * Now squash the pending reflection events for this channel. + */ - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_DeleteEvents(ReflectEventDelete, rcPtr); + + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -1241,7 +1253,7 @@ ReflectClose( } #endif - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); #ifdef TCL_THREADS } #endif @@ -1349,7 +1361,7 @@ ReflectInput( *errorCodePtr = EOK; if (bytec > 0) { - memcpy(buf, bytev, (size_t)bytec); + memcpy(buf, bytev, (size_t) bytec); } stop: @@ -1550,12 +1562,13 @@ ReflectSeekWide( Tcl_Preserve(rcPtr); offObj = Tcl_NewWideIntObj(offset); - baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? "start" : - ((seekMode == SEEK_CUR) ? "current" : "end"), -1); + baseObj = Tcl_NewStringObj( + (seekMode == SEEK_SET) ? "start" : + (seekMode == SEEK_CUR) ? "current" : "end", -1); Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); - if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } @@ -1773,7 +1786,7 @@ ReflectThread(ClientData clientData, int action) rcPtr->owner = NULL; break; default: - Tcl_Panic ("Unknown thread action code."); + Tcl_Panic("Unknown thread action code."); break; } } @@ -2047,7 +2060,8 @@ EncodeEventMask( } if (listc < 1) { - Tcl_AppendResult(interp, "bad ", objName, " list: is empty", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad %s list: is empty", objName)); return TCL_ERROR; } @@ -2808,7 +2822,7 @@ DeleteThreadReflectedChannelMap( * actually. */ - Tcl_DeleteEvents (ReflectEventDelete, NULL); + Tcl_DeleteEvents(ReflectEventDelete, NULL); /* * Get the map of all channels handled by the current thread. This is a @@ -2979,9 +2993,8 @@ ForwardProc( Tcl_Interp *interp = rcPtr->interp; ForwardParam *paramPtr = evPtr->param; Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ - ReflectedChannelMap *rcmPtr; - /* Map of reflected channels with handlers in - * this interp. */ + ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in + * this interp. */ Tcl_HashEntry *hPtr; /* Entry in the above map */ /* @@ -3024,12 +3037,12 @@ ForwardProc( rcmPtr = GetReflectedChannelMap(interp); hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); + Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); + Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); FreeReflectedChannelArgs(rcPtr); @@ -3064,7 +3077,7 @@ ForwardProc( paramPtr->input.toRead = -1; } else { if (bytec > 0) { - memcpy(paramPtr->input.buf, bytev, (size_t)bytec); + memcpy(paramPtr->input.buf, bytev, (size_t) bytec); } paramPtr->input.toRead = bytec; } @@ -3076,7 +3089,7 @@ ForwardProc( case ForwardedOutput: { Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) - paramPtr->output.buf, paramPtr->output.toWrite); + paramPtr->output.buf, paramPtr->output.toWrite); Tcl_IncrRefCount(bufObj); Tcl_Preserve(rcPtr); @@ -3116,8 +3129,8 @@ ForwardProc( case ForwardedSeek: { Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset); Tcl_Obj *baseObj = Tcl_NewStringObj( - (paramPtr->seek.seekMode==SEEK_SET) ? "start" : - (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); + (paramPtr->seek.seekMode==SEEK_SET) ? "start" : + (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); @@ -3167,11 +3180,11 @@ ForwardProc( case ForwardedBlock: { Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking); - Tcl_IncrRefCount(blockObj); + Tcl_IncrRefCount(blockObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); @@ -3187,7 +3200,7 @@ ForwardProc( Tcl_IncrRefCount(valueObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); @@ -3202,8 +3215,8 @@ ForwardProc( */ Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1); - Tcl_IncrRefCount(optionObj); + Tcl_IncrRefCount(optionObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 8f111b0..2b9efb9 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -363,33 +363,43 @@ static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ - if ((p)->base.mustFree) { \ - ckfree((p)->base.msgStr); \ - } + do { \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ + } \ + } while (0) #define PassReceivedErrorInterp(i,p) \ - if ((i) != NULL) { \ - Tcl_SetChannelErrorInterp((i), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - } \ - FreeReceivedError(p) + do { \ + if ((i) != NULL) { \ + Tcl_SetChannelErrorInterp((i), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + } \ + FreeReceivedError(p); \ + } while (0) #define PassReceivedError(c,p) \ - Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ - FreeReceivedError(p) + do { \ + Tcl_SetChannelError((c), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + FreeReceivedError(p); \ + } while (0) #define ForwardSetStaticError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 0; \ - (p)->base.msgStr = (char *) (emsg) + do { \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 0; \ + (p)->base.msgStr = (char *) (emsg); \ + } while (0) #define ForwardSetDynamicError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 1; \ - (p)->base.msgStr = (char *) (emsg) + do { \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 1; \ + (p)->base.msgStr = (char *) (emsg); \ + } while (0) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); - static ReflectedTransformMap * GetThreadReflectedTransformMap(void); -static void DeleteThreadReflectedTransformMap(ClientData clientData); - +static void DeleteThreadReflectedTransformMap( + ClientData clientData); #endif /* TCL_THREADS */ #define SetChannelErrorStr(c,msgStr) \ @@ -513,7 +523,6 @@ TclChanPushObjCmd( int result; /* Result code for 'initialize' */ Tcl_Obj *resObj; /* Result data for 'initialize' */ int methods; /* Bitmask for supported methods. */ - Tcl_Obj *err; /* Error message */ ReflectedTransformMap *rtmPtr; /* Map of reflected transforms with handlers * in this interp. */ @@ -608,11 +617,10 @@ TclChanPushObjCmd( while (listc > 0) { if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, " initialize\" returned ", -1); - Tcl_AppendObjToObj(err, Tcl_GetObjResult(interp)); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s initialize\" returned %s", + Tcl_GetString(cmdObj), + Tcl_GetString(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(resObj); goto error; } @@ -695,13 +703,14 @@ TclChanPushObjCmd( rtmPtr = GetThreadReflectedTransformMap(); hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); Tcl_SetHashValue(hPtr, rtPtr); -#endif +#endif /* TCL_THREADS */ /* * Return the channel as the result of the command. */ - Tcl_AppendResult(interp, Tcl_GetChannelName(rtPtr->chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_GetChannelName(rtPtr->chan), -1)); return TCL_OK; error: @@ -710,7 +719,7 @@ TclChanPushObjCmd( * structure. */ - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return TCL_ERROR; #undef CHAN @@ -913,9 +922,9 @@ ReflectClose( FreeReceivedError(&p); } } -#endif +#endif /* TCL_THREADS */ - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return EOK; } @@ -931,11 +940,11 @@ ReflectClose( if (!TransformDrain(rtPtr, &errorCode)) { #ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { - Tcl_EventuallyFree (rtPtr, + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; } -#endif +#endif /* TCL_THREADS */ errorCodeSet = 1; goto cleanup; } @@ -945,11 +954,11 @@ ReflectClose( if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) { #ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { - Tcl_EventuallyFree (rtPtr, + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; } -#endif +#endif /* TCL_THREADS */ errorCodeSet = 1; goto cleanup; } @@ -966,7 +975,7 @@ ReflectClose( ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); result = p.base.code; - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -974,7 +983,7 @@ ReflectClose( } return EOK; } -#endif +#endif /* TCL_THREADS */ /* * Do the actual invokation of "finalize" now; we're in the right thread. @@ -1022,7 +1031,7 @@ ReflectClose( if (hPtr) { Tcl_DeleteHashEntry(hPtr); } -#endif +#endif /* TCL_THREADS */ } Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); @@ -1348,7 +1357,7 @@ ReflectSeekWide( * transformation. */ - if ((rtPtr->methods & FLAG(METH_CLEAR))) { + if (rtPtr->methods & FLAG(METH_CLEAR)) { TransformClear(rtPtr); } @@ -2140,7 +2149,7 @@ DeleteReflectedTransformMap( ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; -#endif +#endif /* TCL_THREADS */ /* * Delete all entries. The channels may have been closed already, or will @@ -2232,8 +2241,7 @@ DeleteReflectedTransformMap( Tcl_ConditionNotify(&resultPtr->done); } Tcl_MutexUnlock(&rtForwardMutex); - -#endif +#endif /* TCL_THREADS */ } #ifdef TCL_THREADS @@ -2631,7 +2639,7 @@ ForwardProc( break; } - case ForwardedDrain: { + case ForwardedDrain: if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); paramPtr->transform.size = -1; @@ -2656,9 +2664,8 @@ ForwardProc( } } break; - } - case ForwardedFlush: { + case ForwardedFlush: if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); paramPtr->transform.size = -1; @@ -2684,12 +2691,10 @@ ForwardProc( } } break; - } - case ForwardedClear: { + case ForwardedClear: (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL); break; - } case ForwardedLimit: if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) { @@ -2795,7 +2800,7 @@ ForwardSetObjError( ForwardSetDynamicError(paramPtr, ckalloc(len)); memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len); } -#endif +#endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- @@ -3092,7 +3097,7 @@ TransformRead( ckfree(p.transform.buf); return 1; } -#endif +#endif /* TCL_THREADS */ /* ASSERT: rtPtr->method & FLAG(METH_READ) */ /* ASSERT: rtPtr->mode & TCL_READABLE */ @@ -3153,7 +3158,7 @@ TransformWrite( p.transform.size); ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */ /* ASSERT: rtPtr->mode & TCL_WRITABLE */ @@ -3215,7 +3220,7 @@ TransformDrain( ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size); ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); @@ -3270,7 +3275,7 @@ TransformFlush( } ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); @@ -3311,7 +3316,7 @@ TransformClear( ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p); return; } -#endif +#endif /* TCL_THREADS */ /* ASSERT: rtPtr->method & FLAG(METH_READ) */ /* ASSERT: rtPtr->mode & TCL_READABLE */ diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 018f9f5..e603c91 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -64,8 +64,8 @@ TclSockGetPort( return TCL_ERROR; } if (*portPtr > 0xFFFF) { - Tcl_AppendResult(interp, "couldn't open socket: port number too high", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't open socket: port number too high", -1)); return TCL_ERROR; } return TCL_OK; @@ -100,16 +100,20 @@ TclSockMinimumBuffers( socklen_t len; len = sizeof(int); - getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); + getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, + (char *) ¤t, &len); if (current < size) { len = sizeof(int); - setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len); + setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, + (char *) &size, len); } len = sizeof(int); - getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); + getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, + (char *) ¤t, &len); if (current < size) { len = sizeof(int); - setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); + setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, + (char *) &size, len); } return TCL_OK; } @@ -152,19 +156,18 @@ TclCreateSocketAddress( Tcl_DString ds; int result, i; - TclFormatInt(portstring, port); - if (host != NULL) { native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); } - + TclFormatInt(portstring, port); (void) memset(&hints, 0, sizeof(hints)); - hints.ai_family = AF_UNSPEC; + /* * Magic variable to enforce a certain address family - to be superseded * by a TIP that adds explicit switches to [socket] */ + if (interp != NULL) { family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0); if (family != NULL) { @@ -182,7 +185,7 @@ TclCreateSocketAddress( /* * We found some problems when using AI_ADDRCONFIG, e.g. on systems that * have no networking besides the loopback interface and want to resolve - * localhost. See bugs 3385024, 3382419, 3382431. As the advantage of + * localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of * using AI_ADDRCONFIG in situations where it works, is probably low, * we'll leave it out for now. After all, it is just an optimisation. * @@ -206,12 +209,11 @@ TclCreateSocketAddress( } if (result != 0) { -#ifdef EAI_SYSTEM /* Doesn't exist on Windows */ - if (result == EAI_SYSTEM) - *errorMsgPtr = Tcl_PosixError(interp); - else -#endif - *errorMsgPtr = gai_strerror(result); + *errorMsgPtr = +#ifdef EAI_SYSTEM /* Doesn't exist on Windows */ + (result == EAI_SYSTEM) ? Tcl_PosixError(interp) : +#endif /* EAI_SYSTEM */ + gai_strerror(result); return 0; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index ebf34dc..115c132 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1573,8 +1573,8 @@ TclGetOpenModeEx( *seekFlagPtr = 0; *binaryPtr = 0; if (interp != NULL) { - Tcl_AppendResult(interp, "illegal access mode \"", modeString, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal access mode \"%s\"", modeString)); } return -1; } @@ -1623,8 +1623,9 @@ TclGetOpenModeEx( mode |= O_NOCTTY; #else if (interp != NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } ckfree(modeArgv); return -1; @@ -1635,8 +1636,9 @@ TclGetOpenModeEx( mode |= O_NONBLOCK; #else if (interp != NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } ckfree(modeArgv); return -1; @@ -1649,9 +1651,10 @@ TclGetOpenModeEx( } else { if (interp != NULL) { - Tcl_AppendResult(interp, "invalid access mode \"", flag, - "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " - "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid access mode \"%s\": must be RDONLY, WRONLY, " + "RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK," + " or TRUNC", flag)); } ckfree(modeArgv); return -1; @@ -1662,8 +1665,9 @@ TclGetOpenModeEx( if (!gotRW) { if (interp != NULL) { - Tcl_AppendResult(interp, "access mode must include either" - " RDONLY, WRONLY, or RDWR", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "access mode must include either RDONLY, WRONLY, or RDWR", + -1)); } return -1; } @@ -1722,15 +1726,16 @@ Tcl_FSEvalFileEx( if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } @@ -1764,8 +1769,9 @@ Tcl_FSEvalFileEx( if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } string = Tcl_GetString(objPtr); @@ -1778,8 +1784,9 @@ Tcl_FSEvalFileEx( if (Tcl_ReadChars(chan, objPtr, -1, memcmp(string, "\xef\xbb\xbf", 3)) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } @@ -1853,15 +1860,16 @@ TclNREvalFile( if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1895,8 +1903,9 @@ TclNREvalFile( if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -1910,8 +1919,9 @@ TclNREvalFile( if (Tcl_ReadChars(chan, objPtr, -1, memcmp(string, "\xef\xbb\xbf", 3)) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -2247,9 +2257,9 @@ Tcl_FSOpenFileChannel( if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END) < (Tcl_WideInt) 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not seek to end of file " - "while opening \"", Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not seek to end of file while opening \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } Tcl_Close(NULL, retVal); return NULL; @@ -2266,8 +2276,9 @@ Tcl_FSOpenFileChannel( Tcl_SetErrno(ENOENT); if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -2685,9 +2696,9 @@ Tcl_FSGetCwd( Disclaim(); goto cdDidNotChange; } else if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } } Disclaim(); @@ -2761,9 +2772,9 @@ Tcl_FSGetCwd( retCd = proc2(tsdPtr->cwdClientData); if (retCd == NULL && interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } if (retCd == tsdPtr->cwdClientData) { @@ -3153,8 +3164,9 @@ Tcl_LoadFile( */ if (Tcl_FSAccess(pathPtr, R_OK) != 0) { - Tcl_AppendResult(interp, "couldn't load library \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load library \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -3204,7 +3216,7 @@ Tcl_LoadFile( mustCopyToTempAnyway: Tcl_ResetResult(interp); -#endif +#endif /* TCL_LOAD_FROM_MEMORY */ /* * Get a temporary filename to use, first to copy the file into, and then @@ -3224,8 +3236,8 @@ Tcl_LoadFile( Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); - Tcl_AppendResult(interp, "couldn't load from current filesystem", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't load from current filesystem", -1)); return TCL_ERROR; } diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 9193c1a..f266443 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -148,8 +148,9 @@ TclMacOSXGetFileAttribute( result = TclpObjStat(fileName, &statBuf); if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -159,8 +160,8 @@ TclMacOSXGetFileAttribute( */ errno = EISDIR; - Tcl_AppendResult(interp, "invalid attribute: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid attribute: %s", Tcl_PosixError(interp))); return TCL_ERROR; } @@ -175,8 +176,9 @@ TclMacOSXGetFileAttribute( result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { - Tcl_AppendResult(interp, "could not read attributes of \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read attributes of \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -199,10 +201,11 @@ TclMacOSXGetFileAttribute( } return TCL_OK; #else - Tcl_AppendResult(interp, "Mac OS X file attributes not supported", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Mac OS X file attributes not supported", -1)); Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); return TCL_ERROR; -#endif +#endif /* HAVE_GETATTRLIST */ } /* @@ -241,8 +244,9 @@ TclMacOSXSetFileAttribute( result = TclpObjStat(fileName, &statBuf); if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -252,8 +256,8 @@ TclMacOSXSetFileAttribute( */ errno = EISDIR; - Tcl_AppendResult(interp, "invalid attribute: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid attribute: %s", Tcl_PosixError(interp))); return TCL_ERROR; } @@ -268,8 +272,9 @@ TclMacOSXSetFileAttribute( result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { - Tcl_AppendResult(interp, "could not read attributes of \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read attributes of \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -306,9 +311,9 @@ TclMacOSXSetFileAttribute( &finfo.data, sizeof(finfo.data), 0); if (result != 0) { - Tcl_AppendResult(interp, "could not set attributes of \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set attributes of \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } } else { @@ -328,8 +333,8 @@ TclMacOSXSetFileAttribute( */ if (newRsrcForkSize != 0) { - Tcl_AppendResult(interp, - "setting nonzero rsrclength not supported", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "setting nonzero rsrclength not supported", -1)); Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); return TCL_ERROR; } @@ -360,17 +365,17 @@ TclMacOSXSetFileAttribute( Tcl_DStringFree(&ds); if (result != 0) { - Tcl_AppendResult(interp, - "could not truncate resource fork of \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not truncate resource fork of \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } } } return TCL_OK; #else - Tcl_AppendResult(interp, "Mac OS X file attributes not supported", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Mac OS X file attributes not supported", -1)); Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); return TCL_ERROR; #endif @@ -640,8 +645,8 @@ SetOSTypeFromAny( if (Tcl_DStringLength(&ds) > 4) { if (interp) { - Tcl_AppendResult(interp, "expected Macintosh OS type but got \"", - string, "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected Macintosh OS type but got \"%s\": ", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", NULL); } result = TCL_ERROR; diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 3845c44..9ee37f1 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -136,10 +136,10 @@ typedef struct TtyAttrs { #endif /* !SUPPORTS_TTY */ #define UNSUPPORTED_OPTION(detail) \ - if (interp) { \ - Tcl_AppendResult(interp, (detail), \ - " not supported for this platform", NULL); \ - Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ + "%s not supported for this platform", (detail))); \ + Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \ } /* @@ -697,9 +697,9 @@ TtySetOptionProc( return TCL_ERROR; } else { if (interp) { - Tcl_AppendResult(interp, "bad value for -handshake: " - "must be one of xonxoff, rtscts, dtrdsr or none", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -handshake: must be one of" + " xonxoff, rtscts, dtrdsr or none", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } @@ -720,8 +720,9 @@ TtySetOptionProc( return TCL_ERROR; } else if (argc != 2) { if (interp) { - Tcl_AppendResult(interp, "bad value for -xchar: " - "should be a list of two elements", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -xchar: should be a list of" + " two elements", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } @@ -773,8 +774,9 @@ TtySetOptionProc( } if ((argc % 2) == 1) { if (interp) { - Tcl_AppendResult(interp, "bad value for -ttycontrol: " - "should be a list of signal,value pairs", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -ttycontrol: should be a list of" + " signal,value pairs", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } @@ -822,9 +824,9 @@ TtySetOptionProc( #endif /* SETBREAK */ } else { if (interp) { - Tcl_AppendResult(interp, "bad signal \"", argv[i], - "\" for -ttycontrol: must be " - "DTR, RTS or BREAK", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad signal \"%s\" for -ttycontrol: must be" + " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } @@ -1388,8 +1390,8 @@ TtyParseMode( stopPtr, &end); if ((i != 4) || (mode[end] != '\0')) { if (interp != NULL) { - Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s: should be baud,parity,data,stop", bad)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; @@ -1412,13 +1414,14 @@ TtyParseMode( #endif /* PAREXT|USE_TERMIO */ == NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, bad, " parity: should be ", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s parity: should be %s", bad, #if defined(PAREXT) || defined(USE_TERMIO) - "n, o, e, m, or s", + "n, o, e, m, or s" #else - "n, o, or e", + "n, o, or e" #endif /* PAREXT|USE_TERMIO */ - NULL); + )); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; @@ -1426,15 +1429,16 @@ TtyParseMode( *parityPtr = parity; if ((*dataPtr < 5) || (*dataPtr > 8)) { if (interp != NULL) { - Tcl_AppendResult(interp, bad, " data: should be 5, 6, 7, or 8", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s data: should be 5, 6, 7, or 8", bad)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; } if ((*stopPtr < 0) || (*stopPtr > 2)) { if (interp != NULL) { - Tcl_AppendResult(interp, bad, " stop: should be 1 or 2", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s stop: should be 1 or 2", bad)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; @@ -1583,8 +1587,9 @@ TclpOpenFileChannel( if (fd < 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -1842,15 +1847,15 @@ Tcl_GetOpenFile( if (chan == NULL) { return TCL_ERROR; } - if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) { - Tcl_AppendResult(interp, "\"", chanID, "\" wasn't opened for writing", - NULL); + if (forWriting && !(chanMode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" wasn't opened for writing", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_WRITABLE", NULL); return TCL_ERROR; - } else if ((!forWriting) && ((chanMode & TCL_READABLE) == 0)) { - Tcl_AppendResult(interp, "\"", chanID, "\" wasn't opened for reading", - NULL); + } else if (!forWriting && !(chanMode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" wasn't opened for reading", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_READABLE", NULL); return TCL_ERROR; @@ -1881,8 +1886,8 @@ Tcl_GetOpenFile( f = fdopen(fd, (forWriting ? "w" : "r")); if (f == NULL) { - Tcl_AppendResult(interp, "cannot get a FILE * for \"", chanID, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot get a FILE * for \"%s\"", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "FILE_FAILURE", NULL); return TCL_ERROR; @@ -1892,8 +1897,8 @@ Tcl_GetOpenFile( } } - Tcl_AppendResult(interp, "\"", chanID, - "\" cannot be used to get a FILE *", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" cannot be used to get a FILE *", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NO_DESCRIPTOR", NULL); return TCL_ERROR; diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index a695e9c..d3cc6bf 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -1320,9 +1320,9 @@ GetGroupAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1374,9 +1374,9 @@ GetOwnerAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1425,9 +1425,9 @@ GetPermissionsAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1478,9 +1478,10 @@ SetGroupAttribute( if (groupPtr == NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set group for file \"", - TclGetString(fileName), "\": group \"", string, - "\" does not exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set group for file \"%s\":" + " group \"%s\" does not exist", + TclGetString(fileName), string)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETGRP", "NO_GROUP", NULL); } @@ -1494,9 +1495,9 @@ SetGroupAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set group for file \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set group for file \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1544,9 +1545,10 @@ SetOwnerAttribute( if (pwPtr == NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set owner for file \"", - TclGetString(fileName), "\": user \"", string, - "\" does not exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set owner for file \"%s\":" + " user \"%s\" does not exist", + TclGetString(fileName), string)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETOWN", "NO_USER", NULL); } @@ -1560,9 +1562,9 @@ SetOwnerAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set owner for file \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set owner for file \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1630,9 +1632,9 @@ SetPermissionsAttribute( result = TclpObjStat(fileName, &buf); if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1640,8 +1642,9 @@ SetPermissionsAttribute( if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) { if (interp != NULL) { - Tcl_AppendResult(interp, "unknown permission string format \"", - modeStringPtr, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown permission string format \"%s\"", + modeStringPtr)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL); } return TCL_ERROR; @@ -1652,9 +1655,9 @@ SetPermissionsAttribute( result = chmod(native, newMode); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set permissions for file \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set permissions for file \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2239,14 +2242,14 @@ GetReadOnlyAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } - *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags&UF_IMMUTABLE) != 0); + *attributePtrPtr = Tcl_NewBooleanObj(statBuf.st_flags&UF_IMMUTABLE); return TCL_OK; } @@ -2286,9 +2289,9 @@ SetReadOnlyAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2303,9 +2306,9 @@ SetReadOnlyAttribute( result = chflags(native, statBuf.st_flags); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set flags for file \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set flags for file \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index c213050..01fc6fe 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -310,10 +310,9 @@ TclpMatchInDirectory( if (d == NULL) { Tcl_DStringFree(&ds); if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(&dsOrig), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read directory \"%s\": %s", + Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp))); } Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); @@ -771,9 +770,9 @@ TclpGetCwd( #endif { if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } return NULL; } diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 377b84b..654c9d8 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -267,35 +267,34 @@ TclpTempFileName(void) } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------------- * * TclpTempFileNameForLibrary -- * - * Constructs a file name in the native file system where a - * dynamically loaded library may be placed. + * Constructs a file name in the native file system where a dynamically + * loaded library may be placed. * * Results: - * Returns the constructed file name. If an error occurs, - * returns NULL and leaves an error message in the interpreter - * result. + * Returns the constructed file name. If an error occurs, returns NULL + * and leaves an error message in the interpreter result. * - * On Unix, it works to load a shared object from a file of any - * name, so this function is merely a thin wrapper around - * TclpTempFileName(). + * On Unix, it works to load a shared object from a file of any name, so this + * function is merely a thin wrapper around TclpTempFileName(). * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------------- */ -Tcl_Obj* -TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_Obj* path) /* Path name of the library - * in the VFS */ +Tcl_Obj * +TclpTempFileNameForLibrary( + Tcl_Interp *interp, /* Tcl interpreter. */ + Tcl_Obj *path) /* Path name of the library in the VFS. */ { - Tcl_Obj* retval; - retval = TclpTempFileName(); + Tcl_Obj *retval = TclpTempFileName(); + if (retval == NULL) { - Tcl_AppendResult(interp, "couldn't create temporary file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create temporary file: %s", + Tcl_PosixError(interp))); } return retval; } @@ -442,8 +441,8 @@ TclpCreateProcess( */ if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) { - Tcl_AppendResult(interp, "couldn't create pipe: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create pipe: %s", Tcl_PosixError(interp))); goto error; } @@ -463,8 +462,9 @@ TclpCreateProcess( /* * After vfork(), do not call code in the child that changes global state, * because it is using the parent's memory space at that point and writes - * might corrupt the parent: so ensure standard channels are initialized in - * the parent, otherwise SetupStdFile() might initialize them in the child. + * might corrupt the parent: so ensure standard channels are initialized + * in the parent, otherwise SetupStdFile() might initialize them in the + * child. */ if (!inputFile) { @@ -495,7 +495,7 @@ TclpCreateProcess( || (joinThisError && ((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) { sprintf(errSpace, - "%dforked process couldn't set up input/output: ", errno); + "%dforked process couldn't set up input/output", errno); len = strlen(errSpace); if (len != (size_t) write(fd, errSpace, len)) { Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut"); @@ -509,11 +509,11 @@ TclpCreateProcess( RestoreSignals(); execvp(newArgv[0], newArgv); /* INTL: Native. */ - sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]); + sprintf(errSpace, "%dcouldn't execute \"%.150s\"", errno, argv[0]); len = strlen(errSpace); - if (len != (size_t) write(fd, errSpace, len)) { + if (len != (size_t) write(fd, errSpace, len)) { Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut"); - } + } _exit(1); } @@ -528,8 +528,8 @@ TclpCreateProcess( TclStackFree(interp, dsArray); if (pid == -1) { - Tcl_AppendResult(interp, "couldn't fork child process: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't fork child process: %s", Tcl_PosixError(interp))); goto error; } @@ -546,9 +546,11 @@ TclpCreateProcess( count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1)); if (count > 0) { char *end; + errSpace[count] = 0; errno = strtol(errSpace, &end, 10); - Tcl_AppendResult(interp, end, Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s: %s", + end, Tcl_PosixError(interp))); goto error; } @@ -832,8 +834,8 @@ Tcl_CreatePipe( int fileNums[2]; if (pipe(fileNums) < 0) { - Tcl_AppendResult(interp, "pipe creation failed: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("pipe creation failed: %s", + Tcl_PosixError(interp))); return TCL_ERROR; } diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 1e9d4eb..102c620 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -21,10 +21,10 @@ #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) /* "sock" + a pointer in hex + \0 */ -#define SOCK_CHAN_LENGTH 4 + sizeof(void*) * 2 + 1 -#define SOCK_TEMPLATE "sock%lx" +#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) +#define SOCK_TEMPLATE "sock%lx" -#undef SOCKET /* Possible conflict with win32 SOCKET */ +#undef SOCKET /* Possible conflict with win32 SOCKET */ /* * This is needed to comply with the strict aliasing rules of GCC, but it also @@ -58,19 +58,23 @@ struct TcpState { /* * Only needed for server sockets */ - Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ - ClientData acceptProcData; /* The data for the accept proc. */ + + Tcl_TcpAcceptProc *acceptProc; + /* Proc to call on accept. */ + ClientData acceptProcData; /* The data for the accept proc. */ + /* * Only needed for client sockets */ - struct addrinfo *addrlist; /* addresses to connect to */ - struct addrinfo *addr; /* iterator over addrlist */ - struct addrinfo *myaddrlist; /* local address */ - struct addrinfo *myaddr; /* iterator over myaddrlist */ - int filehandlers; /* Caches FileHandlers that get set up while - * an async socket is not yet connected */ - int status; /* Cache status of async socket */ - int cachedBlocking; /* Cache blocking mode of async socket */ + + struct addrinfo *addrlist; /* Addresses to connect to. */ + struct addrinfo *addr; /* Iterator over addrlist. */ + struct addrinfo *myaddrlist;/* Local address. */ + struct addrinfo *myaddr; /* Iterator over myaddrlist. */ + int filehandlers; /* Caches FileHandlers that get set up while + * an async socket is not yet connected. */ + int status; /* Cache status of async socket. */ + int cachedBlocking; /* Cache blocking mode of async socket. */ }; /* @@ -90,9 +94,7 @@ struct TcpState { #ifndef SOMAXCONN # define SOMAXCONN 100 -#endif /* SOMAXCONN */ - -#if (SOMAXCONN < 100) +#elif (SOMAXCONN < 100) # undef SOMAXCONN # define SOMAXCONN 100 #endif /* SOMAXCONN < 100 */ @@ -217,7 +219,7 @@ InitializeHostName( if (native == NULL) { native = tclEmptyStringRep; } -#else +#else /* !NO_UNAME */ /* * Uname doesn't exist; try gethostname instead. * @@ -242,7 +244,7 @@ InitializeHostName( if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */ native = buffer; } -#endif +#endif /* NO_UNAME */ *encodingPtr = Tcl_GetEncoding(NULL, NULL); *lengthPtr = strlen(native); @@ -344,7 +346,7 @@ TcpBlockModeProc( * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; if (mode == TCL_MODE_BLOCKING) { CLEAR_BITS(statePtr->flags, TCP_ASYNC_SOCKET); @@ -443,7 +445,7 @@ TcpInputProc( * buffer? */ int *errorCodePtr) /* Where to store error code. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; int bytesRead; *errorCodePtr = 0; @@ -493,7 +495,7 @@ TcpOutputProc( int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; int written; *errorCodePtr = 0; @@ -532,7 +534,7 @@ TcpCloseProc( ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp) /* For error reporting - unused. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; int errorCode = 0; TcpFdList *fds; @@ -593,7 +595,7 @@ TcpClose2Proc( Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; int errorCode = 0; int sd; @@ -610,8 +612,8 @@ TcpClose2Proc( break; default: if (interp) { - Tcl_AppendResult(interp, - "Socket close2proc called bidirectionally", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "socket close2proc called bidirectionally", -1)); } return TCL_ERROR; } @@ -653,7 +655,7 @@ TcpGetOptionProc( Tcl_DString *dsPtr) /* Where to store the computed value; * initialized by caller. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; char host[NI_MAXHOST], port[NI_MAXSERV]; size_t len = 0; int reverseDNS = 0; @@ -670,7 +672,7 @@ TcpGetOptionProc( if (statePtr->status == 0) { ret = getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, - (char *)&err, &optlen); + (char *) &err, &optlen); if (ret < 0) { err = errno; } @@ -688,9 +690,8 @@ TcpGetOptionProc( reverseDNS = NI_NUMERICHOST; } - if ((len == 0) || - ((len > 1) && (optionName[1] == 'p') && - (strncmp(optionName, "-peername", len) == 0))) { + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { address peername; socklen_t size = sizeof(peername); @@ -721,16 +722,16 @@ TcpGetOptionProc( if (len) { if (interp) { - Tcl_AppendResult(interp, "can't get peername: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get peername: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } } } - if ((len == 0) || - ((len > 1) && (optionName[1] == 's') && + if ((len == 0) || ((len > 1) && (optionName[1] == 's') && (strncmp(optionName, "-sockname", len) == 0))) { TcpFdList *fds; address sockname; @@ -772,7 +773,7 @@ TcpGetOptionProc( sockname.sa6.sin6_addr.s6_addr[15] == 0)) { flags |= NI_NUMERICHOST; } -#endif +#endif /* NEED_FAKE_RFC2553 */ } getnameinfo(&sockname.sa, size, host, sizeof(host), port, sizeof(port), flags); @@ -787,8 +788,8 @@ TcpGetOptionProc( Tcl_DStringEndSublist(dsPtr); } else { if (interp) { - Tcl_AppendResult(interp, "can't get sockname: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get sockname: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -825,7 +826,7 @@ TcpWatchProc( * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; if (statePtr->acceptProc != NULL) { /* @@ -842,8 +843,7 @@ TcpWatchProc( statePtr->filehandlers = mask; } else if (mask) { Tcl_CreateFileHandler(statePtr->fds.fd, mask, - (Tcl_FileProc *) Tcl_NotifyChannel, - (ClientData) statePtr->channel); + (Tcl_FileProc *) Tcl_NotifyChannel, statePtr->channel); } else { Tcl_DeleteFileHandler(statePtr->fds.fd); } @@ -874,7 +874,7 @@ TcpGetHandleProc( int direction, /* Not used. */ ClientData *handlePtr) /* Where to store the handle. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; *handlePtr = INT2PTR(statePtr->fds.fd); return TCL_OK; @@ -946,12 +946,11 @@ CreateClientSocket( } for (state->addr = state->addrlist; state->addr != NULL; - state->addr = state->addr->ai_next) { - + state->addr = state->addr->ai_next) { status = -1; for (state->myaddr = state->myaddrlist; state->myaddr != NULL; - state->myaddr = state->myaddr->ai_next) { + state->myaddr = state->myaddr->ai_next) { int reuseaddr; /* @@ -967,6 +966,7 @@ CreateClientSocket( * Close the socket if it is still open from the last unsuccessful * iteration. */ + if (state->fds.fd >= 0) { close(state->fds.fd); state->fds.fd = -1; @@ -991,7 +991,8 @@ CreateClientSocket( TclSockMinimumBuffers(INT2PTR(state->fds.fd), SOCKET_BUFSIZE); if (async) { - status = TclUnixSetBlockingMode(state->fds.fd, TCL_MODE_NONBLOCKING); + status = TclUnixSetBlockingMode(state->fds.fd, + TCL_MODE_NONBLOCKING); if (status < 0) { continue; } @@ -1001,7 +1002,7 @@ CreateClientSocket( (void) setsockopt(state->fds.fd, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); status = bind(state->fds.fd, state->myaddr->ai_addr, - state->myaddr->ai_addrlen); + state->myaddr->ai_addrlen); if (status < 0) { continue; } @@ -1014,24 +1015,25 @@ CreateClientSocket( */ status = connect(state->fds.fd, state->addr->ai_addr, - state->addr->ai_addrlen); + state->addr->ai_addrlen); if (status < 0 && errno == EINPROGRESS) { Tcl_CreateFileHandler(state->fds.fd, - TCL_WRITABLE | TCL_EXCEPTION, - TcpAsyncCallback, state); + TCL_WRITABLE|TCL_EXCEPTION, TcpAsyncCallback, state); return TCL_OK; reenter: Tcl_DeleteFileHandler(state->fds.fd); + /* * Read the error state from the socket to see if the async * connection has succeeded or failed. As this clears the * error condition, we cache the status in the socket state * struct for later retrieval by [fconfigure -error]. */ + optlen = sizeof(int); getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR, - (char *)&status, &optlen); + (char *) &status, &optlen); state->status = status; } if (status == 0) { @@ -1047,6 +1049,7 @@ out: /* * An asynchonous connection has finally succeeded or failed. */ + TcpWatchProc(state, state->filehandlers); TclUnixSetBlockingMode(state->fds.fd, state->cachedBlocking); @@ -1058,17 +1061,18 @@ out: * hurt that this is also called in the successful case and will save * the event mechanism one roundtrip through select(). */ - Tcl_NotifyChannel(state->channel, TCL_WRITABLE); + Tcl_NotifyChannel(state->channel, TCL_WRITABLE); } else if (status != 0) { /* * Failure for either a synchronous connection, or an async one that * failed before it could enter background mode, e.g. because an * invalid -myaddr was given. */ + if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1111,13 +1115,16 @@ Tcl_OpenTcpClient( /* * Do the name lookups for the local and remote addresses. */ - if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) || - !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, &errorMsg)) { + + if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) + || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, + &errorMsg)) { if (addrlist != NULL) { freeaddrinfo(addrlist); } if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", errorMsg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", errorMsg)); } return NULL; } @@ -1141,10 +1148,10 @@ Tcl_OpenTcpClient( return NULL; } - sprintf(channelName, SOCK_TEMPLATE, (long)state); + sprintf(channelName, SOCK_TEMPLATE, (long) state); - state->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - state, (TCL_READABLE | TCL_WRITABLE)); + state->channel = Tcl_CreateChannel(&tcpChannelType, channelName, state, + (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(interp, state->channel, "-translation", "auto crlf") == TCL_ERROR) { Tcl_Close(NULL, state->channel); @@ -1257,6 +1264,7 @@ Tcl_OpenTcpServer( * Try to record and return the most meaningful error message, i.e. the * one from the first socket that went the farthest before it failed. */ + enum { LOOKUP, SOCKET, BIND, LISTEN } howfar = LOOKUP; int my_errno = 0; @@ -1267,7 +1275,7 @@ Tcl_OpenTcpServer( for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, - addrPtr->ai_protocol); + addrPtr->ai_protocol); if (sock == -1) { if (howfar < SOCKET) { howfar = SOCKET; @@ -1318,7 +1326,7 @@ Tcl_OpenTcpServer( (void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY, &v6only, sizeof(v6only)); } -#endif +#endif /* IPV6_V6ONLY */ status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen); if (status == -1) { @@ -1360,7 +1368,7 @@ Tcl_OpenTcpServer( memset(statePtr, 0, sizeof(TcpState)); statePtr->acceptProc = acceptProc; statePtr->acceptProcData = acceptProcData; - sprintf(channelName, SOCK_TEMPLATE, (long)statePtr); + sprintf(channelName, SOCK_TEMPLATE, (long) statePtr); newfds = &statePtr->fds; } else { newfds = ckalloc(sizeof(TcpFdList)); @@ -1389,13 +1397,15 @@ Tcl_OpenTcpServer( return statePtr->channel; } if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", NULL); + Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", -1); + if (errorMsg == NULL) { errno = my_errno; - Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); + Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), -1); } else { - Tcl_AppendResult(interp, errorMsg, NULL); + Tcl_AppendToObj(errorObj, errorMsg, -1); } + Tcl_SetObjResult(interp, errorObj); } if (sock != -1) { close(sock); @@ -1434,7 +1444,7 @@ TcpAccept( char host[NI_MAXHOST], port[NI_MAXSERV]; len = sizeof(addr); - newsock = accept(fds->fd, &(addr.sa), &len); + newsock = accept(fds->fd, &addr.sa, &len); if (newsock < 0) { return; } @@ -1451,7 +1461,7 @@ TcpAccept( newSockState->flags = 0; newSockState->fds.fd = newsock; - sprintf(channelName, SOCK_TEMPLATE, (long)newSockState); + sprintf(channelName, SOCK_TEMPLATE, (long) newSockState); newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName, newSockState, (TCL_READABLE | TCL_WRITABLE)); @@ -1459,7 +1469,7 @@ TcpAccept( "auto crlf"); if (fds->statePtr->acceptProc != NULL) { - getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), + getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port), NI_NUMERICHOST|NI_NUMERICSERV); fds->statePtr->acceptProc(fds->statePtr->acceptProcData, newSockState->channel, host, atoi(port)); diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 517aa20..bc233ea 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -940,8 +940,9 @@ TclpOpenFileChannel( } TclWinConvertError(err); if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + TclGetString(pathPtr),, Tcl_PosixError(interp))); } return NULL; } @@ -959,9 +960,9 @@ TclpOpenFileChannel( if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't reopen serial \"", - TclGetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't reopen serial \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -995,8 +996,9 @@ TclpOpenFileChannel( */ channel = NULL; - Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), - "\": bad file type", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": bad file type", + TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE", NULL); break; diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 4d6e31b..e225989 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -157,7 +157,8 @@ Dde_Init( #ifdef UNICODE if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) { - Tcl_AppendResult(interp, "Win32s and Windows 9x are not supported platforms", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Win32s and Windows 9x are not supported platforms", -1)); return TCL_ERROR; } #endif @@ -947,8 +948,8 @@ MakeDdeConnection( if (ddeConv == (HCONV) NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, "no registered server named \"", - name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no registered server named \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); } return TCL_ERROR; diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 77a5b82..80fad3e 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1530,8 +1530,8 @@ StatError( * error. */ { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } /* @@ -1649,9 +1649,9 @@ ConvertFileNameFormat( if (splitPath == NULL || pathc == 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - Tcl_GetString(fileName), "\": no such file or directory", - (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": no such file or directory", + Tcl_GetString(fileName))); errno = ENOENT; Tcl_PosixError(interp); } @@ -1941,9 +1941,9 @@ CannotSetAttribute( Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { - Tcl_AppendResult(interp, "cannot set attribute \"", - tclpFileAttrStrings[objIndex], "\" for file \"", - Tcl_GetString(fileName), "\": attribute is readonly", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot set attribute \"%s\" for file \"%s\": attribute is readonly", + tclpFileAttrStrings[objIndex], Tcl_GetString(fileName))); errno = EINVAL; Tcl_PosixError(interp); return TCL_ERROR; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1f56060..a44a257 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1048,10 +1048,9 @@ TclpMatchInDirectory( TclWinConvertError(err); if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(&dsOrig), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read directory \"%s\": %s", + Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp))); } Tcl_DStringFree(&dsOrig); return TCL_ERROR; @@ -1866,8 +1865,9 @@ TclpGetCwd( if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); if (interp != NULL) { - Tcl_AppendResult(interp, "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } return NULL; } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index db462f8..36ae58a 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -1030,8 +1030,9 @@ TclpCreateProcess( } if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate input handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate input handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1065,8 +1066,9 @@ TclpCreateProcess( } if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate output handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate output handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1084,8 +1086,9 @@ TclpCreateProcess( } if (startInfo.hStdError == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate error handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate error handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1129,9 +1132,9 @@ TclpCreateProcess( } if (applType == APPL_DOS) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "DOS application process not supported on this platform", - (char *) NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP", NULL); goto end; @@ -1158,12 +1161,12 @@ TclpCreateProcess( BuildCommandLine(execPath, argc, argv, &cmdLine); - if (CreateProcess(NULL, - (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, - (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { + if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine), + NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, + &procInfo) == 0) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't execute \"", argv[0], - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", + argv[0], Tcl_PosixError(interp))); goto end; } @@ -1409,8 +1412,8 @@ ApplicationType( if (applType == APPL_NONE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't execute \"", originalName, - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", + originalName, Tcl_PosixError(interp))); return APPL_NONE; } @@ -1673,8 +1676,8 @@ Tcl_CreatePipe( if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "pipe creation failed: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "pipe creation failed: %s", Tcl_PosixError(interp))); return TCL_ERROR; } diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 9c08b0c..c4a89e6 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -172,7 +172,7 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } @@ -534,9 +534,9 @@ DeleteValue( result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to delete value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to delete value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -574,7 +574,8 @@ GetKeyNames( { const char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - TCHAR buffer[MAX_KEY_LENGTH]; /* Buffer to hold the subkey name */ + TCHAR buffer[MAX_KEY_LENGTH]; + /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ char *name; /* Subkey name */ @@ -610,9 +611,9 @@ GetKeyNames( if (result == ERROR_NO_MORE_ITEMS) { result = TCL_OK; } else { - Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_AppendResult(interp, "unable to enumerate subkeys of \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to enumerate subkeys of \"%s\": ", + Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } @@ -693,9 +694,9 @@ GetType( RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to get type of value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get type of value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); return TCL_ERROR; } @@ -787,9 +788,9 @@ GetValue( Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to get value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); Tcl_DStringFree(&data); return TCL_ERROR; @@ -1110,8 +1111,8 @@ ParseKeyName( rootName = name; } if (!rootName) { - Tcl_AppendResult(interp, "bad key \"", name, - "\": must start with a valid root", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad key \"%s\": must start with a valid root", name)); Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL); return TCL_ERROR; } diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 58a9eb4..fb7f69b 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1673,12 +1673,7 @@ SerialSetOptionProc( if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } native = Tcl_WinUtfToTChar(value, -1, &ds); result = BuildCommDCB(native, &dcb); @@ -1686,8 +1681,9 @@ SerialSetOptionProc( if (result == FALSE) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -mode: should be baud,parity,data,stop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -mode: should be baud,parity,data,stop", + value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; @@ -1703,12 +1699,7 @@ SerialSetOptionProc( dcb.fAbortOnError = FALSE; if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1719,12 +1710,7 @@ SerialSetOptionProc( if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } /* @@ -1759,21 +1745,16 @@ SerialSetOptionProc( dcb.fDtrControl = DTR_CONTROL_HANDSHAKE; } else { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -handshake: must be one of xonxoff, rtscts, " - "dtrdsr or none", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -handshake: must be one of" + " xonxoff, rtscts, dtrdsr or none", value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL); } return TCL_ERROR; } if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1784,12 +1765,7 @@ SerialSetOptionProc( if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { @@ -1798,9 +1774,9 @@ SerialSetOptionProc( if (argc != 2) { badXchar: if (interp != NULL) { - Tcl_AppendResult(interp, "bad value for -xchar: should be " - "a list of two elements with each a single character", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -xchar: should be a list of" + " two elements with each a single character", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); } ckfree(argv); @@ -1837,12 +1813,7 @@ SerialSetOptionProc( ckfree(argv); if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1859,9 +1830,9 @@ SerialSetOptionProc( } if ((argc % 2) == 1) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -ttycontrol: should be a list of " - "signal,value pairs", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -ttycontrol: should be " + "a list of signal,value pairs", value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL); } ckfree(argv); @@ -1877,7 +1848,8 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETDTR : CLRDTR))) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't set DTR signal", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set DTR signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1888,7 +1860,8 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETRTS : CLRRTS))) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't set RTS signal", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set RTS signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1899,7 +1872,8 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETBREAK : CLRBREAK))) { if (interp != NULL) { - Tcl_AppendResult(interp,"can't set BREAK signal",NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set BREAK signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1908,9 +1882,9 @@ SerialSetOptionProc( } } else { if (interp != NULL) { - Tcl_AppendResult(interp, "bad signal name \"", argv[i], - "\" for -ttycontrol: must be DTR, RTS or BREAK", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad signal name \"%s\" for -ttycontrol: must be" + " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL", NULL); } @@ -1949,9 +1923,9 @@ SerialSetOptionProc( if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -sysbuffer: should be a list of one or two " - "integers > 0", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -sysbuffer: should be " + "a list of one or two integers > 0", value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL); } return TCL_ERROR; @@ -1960,8 +1934,9 @@ SerialSetOptionProc( if (!SetupComm(infoPtr->handle, inSize, outSize)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't setup comm buffers: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't setup comm buffers: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1974,22 +1949,12 @@ SerialSetOptionProc( */ if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2); dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4); if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -2020,8 +1985,9 @@ SerialSetOptionProc( if (!SetCommTimeouts(infoPtr->handle, &tout)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm timeouts: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't set comm timeouts: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2031,6 +1997,22 @@ SerialSetOptionProc( return Tcl_BadChannelOption(interp, optionName, "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); + + getStateFailed: + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: ", Tcl_PosixError(interp))); + } + return TCL_ERROR; + + setStateFailed: + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't set comm state: ", Tcl_PosixError(interp))); + } + return TCL_ERROR; } /* @@ -2089,8 +2071,8 @@ SerialGetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2159,8 +2141,8 @@ SerialGetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2237,8 +2219,8 @@ SerialGetOptionProc( if (!GetCommModemStatus(infoPtr->handle, &status)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get tty status: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get tty status: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2248,10 +2230,9 @@ SerialGetOptionProc( if (valid) { return TCL_OK; - } else { - return Tcl_BadChannelOption(interp, optionName, - "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } + return Tcl_BadChannelOption(interp, optionName, + "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 97b10a3..6986528 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -558,8 +558,8 @@ TclpHasSockets( return TCL_OK; } if (interp != NULL) { - Tcl_AppendResult(interp, "sockets are not available on this system", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "sockets are not available on this system", -1)); } return TCL_ERROR; } @@ -928,8 +928,8 @@ TcpClose2Proc( break; default: if (interp) { - Tcl_AppendResult(interp, - "Socket close2proc called bidirectionally", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Socket close2proc called bidirectionally", -1)); } return TCL_ERROR; } @@ -1280,12 +1280,9 @@ CreateSocket( } if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", NULL); - if (errorMsg == NULL) { - Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); - } else { - Tcl_AppendResult(interp, errorMsg, NULL); - } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", + (errorMsg ? errorMsg : Tcl_PosixError(interp))); } if (sock != INVALID_SOCKET) { @@ -1929,7 +1926,8 @@ TcpSetOptionProc( if (!SocketsEnabled()) { if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); } return TCL_ERROR; } @@ -1952,8 +1950,9 @@ TcpSetOptionProc( if (rtn != 0) { TclWinConvertError(WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "couldn't set socket option: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1973,8 +1972,9 @@ TcpSetOptionProc( if (rtn != 0) { TclWinConvertError(WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "couldn't set socket option: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2032,7 +2032,8 @@ TcpGetOptionProc( if (!SocketsEnabled()) { if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); } return TCL_ERROR; } @@ -2099,8 +2100,9 @@ TcpGetOptionProc( if (len) { TclWinConvertError((DWORD) WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "can't get peername: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get peername: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2164,8 +2166,8 @@ TcpGetOptionProc( } else { if (interp) { TclWinConvertError((DWORD) WSAGetLastError()); - Tcl_AppendResult(interp, "can't get sockname: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get sockname: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } -- cgit v0.12 From 6aad9eb5238309785f06a794e5a58496bab884ee Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 5 Aug 2012 20:34:57 +0000 Subject: Fixes to my previous commit, from Francois Vogel. (My thanks and apologies!) --- win/tclWinChan.c | 2 +- win/tclWinSock.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tclWinChan.c b/win/tclWinChan.c index bc233ea..52b9e32 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -942,7 +942,7 @@ TclpOpenFileChannel( if (interp != (Tcl_Interp *) NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": %s", - TclGetString(pathPtr),, Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 6986528..7894920 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1282,7 +1282,7 @@ CreateSocket( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open socket: %s", - (errorMsg ? errorMsg : Tcl_PosixError(interp))); + (errorMsg ? errorMsg : Tcl_PosixError(interp)))); } if (sock != INVALID_SOCKET) { -- cgit v0.12 From 693626defa28c814beb24cbad798b463f61bc9cc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 6 Aug 2012 06:54:36 +0000 Subject: Reference to correct Bug #number --- ChangeLog | 2 +- generic/tclCmdAH.c | 2 +- generic/tclFCmd.c | 2 +- generic/tclIOUtil.c | 2 +- generic/tclTest.c | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index b92cc9b..77d483d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -335,7 +335,7 @@ 2011-11-22 Jan Nijtmans - * generic/tclCmdAH.c: [Bug 2935503] Windows: file mtime + * generic/tclCmdAH.c: [Bug 3354324] Windows: file mtime * generic/tclIOUtil.c: sets wrong time 2011-10-11 Jan Nijtmans diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 63d9111..45e138c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -13,7 +13,7 @@ */ #ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ +/* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 3d6a169..5ad7063 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -11,7 +11,7 @@ */ #ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ +/* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 94d0a6c..69b7e44 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -19,7 +19,7 @@ */ #ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ +/* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif diff --git a/generic/tclTest.c b/generic/tclTest.c index 3bf4b58..8256461 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -16,7 +16,7 @@ */ #ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ +/* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif -- cgit v0.12 From 62fc28c429ba91690e1128e4048629b65dbffdfa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 6 Aug 2012 08:48:57 +0000 Subject: fix two minor blunders, introduced by [1fb35ca910] Only define _USE_32BIT_TIME_T for Tcl build, and only once. --- generic/tclFCmd.c | 5 ----- generic/tclTest.c | 5 ----- win/tclWinPort.h | 2 +- win/tclWinSerial.c | 4 ++-- 4 files changed, 3 insertions(+), 13 deletions(-) diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 6611480..33c1496 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -10,11 +10,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef _WIN64 -/* See [Bug 3354324]: file mtime sets wrong time */ -# define _USE_32BIT_TIME_T -#endif - #include "tclInt.h" #include "tclFileSystem.h" diff --git a/generic/tclTest.c b/generic/tclTest.c index aa5a46d..5dc95f9 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -15,11 +15,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef _WIN64 -/* See [Bug 3354324]: file mtime sets wrong time */ -# define _USE_32BIT_TIME_T -#endif - #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 23e79b0..c6ac2b7 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -14,7 +14,7 @@ #ifndef _TCLWINPORT #define _TCLWINPORT -#ifndef _WIN64 +#if !defined(_WIN64) && defined(BUILD_tcl) /* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index fb7f69b..9e9d1af 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -2002,7 +2002,7 @@ SerialSetOptionProc( if (interp != NULL) { TclWinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get comm state: ", Tcl_PosixError(interp))); + "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; @@ -2010,7 +2010,7 @@ SerialSetOptionProc( if (interp != NULL) { TclWinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't set comm state: ", Tcl_PosixError(interp))); + "can't set comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } -- cgit v0.12 From 8e6d6ece42a8a5c3c298eab5b687e32399f4d160 Mon Sep 17 00:00:00 2001 From: stwo Date: Mon, 6 Aug 2012 11:45:10 +0000 Subject: Installer consistency tweaks. --- unix/Makefile.in | 4 ++-- unix/configure.in | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 068cb12..0ede587 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -856,7 +856,7 @@ install-libraries: libraries @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; - @echo "Installing library encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; + @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \ done; @@ -867,7 +867,7 @@ install-libraries: libraries fi install-tzdata: ${NATIVE_TCLSH} - @echo "Installing time zone data" + @echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/" @${NATIVE_TCLSH} $(TOOL_DIR)/installData.tcl \ $(TOP_DIR)/library/tzdata "$(SCRIPT_INSTALL_DIR)"/tzdata diff --git a/unix/configure.in b/unix/configure.in index c8f0bc6..dc0d543 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -841,8 +841,8 @@ if test "$FRAMEWORK_BUILD" = "1" ; then HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html' - EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' - EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we -- cgit v0.12 From d1b509b35a81bc7887592cec2d56a60edf13ae1f Mon Sep 17 00:00:00 2001 From: stwo Date: Tue, 7 Aug 2012 02:55:38 +0000 Subject: No need for install-sh to be executable. --- unix/Makefile.in | 1 - 1 file changed, 1 deletion(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 0ede587..c369f57 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1928,7 +1928,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M $(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in chmod 775 $(DISTDIR)/unix/ldAix - chmod +x $(DISTDIR)/unix/install-sh mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic -- cgit v0.12 From 7d95f086789039caf71e906e0b8d719982abf9f6 Mon Sep 17 00:00:00 2001 From: stwo Date: Tue, 7 Aug 2012 06:46:59 +0000 Subject: Installer improvements, like [226a993973]. --- unix/Makefile.in | 69 +++---- unix/configure | 4 +- unix/configure.in | 4 +- unix/install-sh | 580 +++++++++++++++++++++++++++++++++++++++++++++--------- 4 files changed, 526 insertions(+), 131 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index a527bf0..bdcbda0 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -151,10 +151,11 @@ SHELL = @MAKEFILE_SHELL@ INSTALL_STRIP_PROGRAM = -s INSTALL_STRIP_LIBRARY = -S -x -INSTALL = @srcdir@/../unix/install-sh -c +INSTALL = $(SHELL) $(UNIX_DIR)/install-sh -c INSTALL_PROGRAM = ${INSTALL} INSTALL_LIBRARY = ${INSTALL} INSTALL_DATA = ${INSTALL} -m 644 +INSTALL_DATA_DIR = ${INSTALL} -d -m 755 # TCL_EXE is the name of a tclsh executable that is available *BEFORE* running # make for the first time. Certain build targets (make genstubs) need it to be @@ -712,14 +713,10 @@ install-binaries: binaries do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; - @if test ! -x $(SRC_DIR)/../unix/install-sh; then \ - chmod +x $(SRC_DIR)/../unix/install-sh; \ - fi @echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/" @@INSTALL_LIB@ @chmod 555 "$(DLL_INSTALL_DIR)"/$(LIB_FILE) @@ -738,8 +735,7 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @@ -747,15 +743,11 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - mkdir -p "$(SCRIPT_INSTALL_DIR)"/$$i; \ - chmod 755 "$(SCRIPT_INSTALL_DIR)"/$$i; \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ else true; \ fi; \ done; - @if test ! -x $(SRC_DIR)/../unix/install-sh; then \ - chmod +x $(SRC_DIR)/../unix/install-sh; \ - fi - @echo "Installing header files"; + @echo "Installing header files to $(INCLUDE_INSTALL_DIR)/"; @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \ $(GENERIC_DIR)/tclPlatDecls.h \ $(GENERIC_DIR)/tclTomMath.h \ @@ -763,20 +755,20 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ $(INSTALL_DATA) $$i "$(INCLUDE_INSTALL_DIR)"; \ done; - @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; + @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"; @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \ $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ done; - @echo "Installing library http1.0 directory"; + @echo "Installing package http1.0 files to $(SCRIPT_INSTALL_DIR)/http1.0/"; @for i in $(TOP_DIR)/library/http1.0/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; @echo "Installing package http 2.7.9 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/http-2.7.9.tm; - @echo "Installing library opt0.4 directory"; + @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ @@ -791,7 +783,7 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; - @echo "Installing library encoding directory"; + @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \ done; @@ -802,40 +794,44 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs fi install-tzdata: ${TCL_EXE} - @echo "Installing time zone data" + @echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/" @@LD_LIBRARY_PATH_VAR@="`pwd`:$${@LD_LIBRARY_PATH_VAR@}"; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./${TCL_EXE} $(TOOL_DIR)/installData.tcl \ $(TOP_DIR)/library/tzdata "$(SCRIPT_INSTALL_DIR)"/tzdata -install-msgs: ${TCL_EXE} - @echo "Installing message catalogs" - @@LD_LIBRARY_PATH_VAR@="`pwd`:$${@LD_LIBRARY_PATH_VAR@}"; export @LD_LIBRARY_PATH_VAR@; \ - TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ - ./${TCL_EXE} $(TOOL_DIR)/installData.tcl \ - $(TOP_DIR)/library/msgs "$(SCRIPT_INSTALL_DIR)"/msgs +install-msgs: + @for i in msgs; \ + do \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ + else true; \ + fi; \ + done; + @echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/" + @for i in $(TOP_DIR)/library/msgs/*.msg ; do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/msgs; \ + done; install-doc: doc @for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)" ; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; - @echo "Installing and cross-linking top-level (.1) docs"; + @echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.1; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \ done - - @echo "Installing and cross-linking C API (.3) docs"; + @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.3; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \ done - - @echo "Installing and cross-linking command (.n) docs"; + @echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.n; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \ done @@ -846,15 +842,11 @@ install-private-headers: libraries do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; - @if test ! -x $(SRC_DIR)/../unix/install-sh; then \ - chmod +x $(SRC_DIR)/../unix/install-sh; \ - fi - @echo "Installing private header files"; + @echo "Installing private header files to $(PRIVATE_INCLUDE_INSTALL_DIR)/"; @for i in $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \ $(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \ $(UNIX_DIR)/tclUnixPort.h; \ @@ -1628,7 +1620,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure $(DISTDIR)/unix chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in chmod 775 $(DISTDIR)/unix/ldAix - chmod +x $(DISTDIR)/unix/install-sh mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic diff --git a/unix/configure b/unix/configure index 753f7c0..4a3a884 100755 --- a/unix/configure +++ b/unix/configure @@ -18989,8 +18989,8 @@ _ACEOF HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html' - EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' - EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we diff --git a/unix/configure.in b/unix/configure.in index 8bab86e..1487752 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -803,8 +803,8 @@ if test "$FRAMEWORK_BUILD" = "1" ; then HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html' - EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' - EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we diff --git a/unix/install-sh b/unix/install-sh index 8cff938..7c34c3f 100755 --- a/unix/install-sh +++ b/unix/install-sh @@ -1,124 +1,528 @@ #!/bin/sh +# install - install a program, script, or datafile + +scriptversion=2011-04-20.01; # UTC +# This originates from X11R5 (mit/util/scripts/install.sh), which was +# later released in X11R6 (xc/config/util/install.sh) with the +# following copyright and license. # -# install - install a program, script, or datafile -# This comes from X11R5; it is not part of GNU. +# Copyright (C) 1994 X Consortium +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- +# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +# +# Except as contained in this notice, the name of the X Consortium shall not +# be used in advertising or otherwise to promote the sale, use or other deal- +# ings in this Software without prior written authorization from the X Consor- +# tium. +# +# +# FSF changes to this file are in the public domain. # -# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. -# +nl=' +' +IFS=" "" $nl" # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" +doit=${DOITPROG-} +if test -z "$doit"; then + doit_exec=exec +else + doit_exec=$doit +fi + +# Put in absolute file names if you don't have them in your path; +# or use environment vars. +chgrpprog=${CHGRPPROG-chgrp} +chmodprog=${CHMODPROG-chmod} +chownprog=${CHOWNPROG-chown} +cmpprog=${CMPPROG-cmp} +cpprog=${CPPROG-cp} +mkdirprog=${MKDIRPROG-mkdir} +mvprog=${MVPROG-mv} +rmprog=${RMPROG-rm} +stripprog=${STRIPPROG-strip} -# put in absolute paths if you don't have them in your path; or use env. vars. +posix_glob='?' +initialize_posix_glob=' + test "$posix_glob" != "?" || { + if (set -f) 2>/dev/null; then + posix_glob= + else + posix_glob=: + fi + } +' -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" +posix_mkdir= -instcmd="$mvprog" -chmodcmd="" -chowncmd="" -chgrpcmd="" -stripcmd="" +# Desired mode of installed file. +mode=0755 + +chgrpcmd= +chmodcmd=$chmodprog +chowncmd= +mvcmd=$mvprog rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd="$cpprog" - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd="$stripprog" - shift - continue;; - - -S) stripcmd="$stripprog $2" - shift - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - dst=$1 - fi - shift - continue;; - esac +stripcmd= + +src= +dst= +dir_arg= +dst_arg= + +copy_on_change=false +no_target_directory= + +usage="\ +Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE + or: $0 [OPTION]... SRCFILES... DIRECTORY + or: $0 [OPTION]... -t DIRECTORY SRCFILES... + or: $0 [OPTION]... -d DIRECTORIES... + +In the 1st form, copy SRCFILE to DSTFILE. +In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. +In the 4th, create DIRECTORIES. + +Options: + --help display this help and exit. + --version display version info and exit. + + -c (ignored) + -C install only if different (preserve the last data modification time) + -d create directories instead of installing files. + -g GROUP $chgrpprog installed files to GROUP. + -m MODE $chmodprog installed files to MODE. + -o USER $chownprog installed files to USER. + -s $stripprog installed files. + -S $stripprog installed files. + -t DIRECTORY install into DIRECTORY. + -T report an error if DSTFILE is a directory. + +Environment variables override the default commands: + CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG + RMPROG STRIPPROG +" + +while test $# -ne 0; do + case $1 in + -c) ;; + + -C) copy_on_change=true;; + + -d) dir_arg=true;; + + -g) chgrpcmd="$chgrpprog $2" + shift;; + + --help) echo "$usage"; exit $?;; + + -m) mode=$2 + case $mode in + *' '* | *' '* | *' +'* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; + + -o) chowncmd="$chownprog $2" + shift;; + + -s) stripcmd=$stripprog;; + + -S) stripcmd="$stripprog $2" + shift;; + + -t) dst_arg=$2 + shift;; + + -T) no_target_directory=true;; + + --version) echo "$0 $scriptversion"; exit $?;; + + --) shift + break;; + + -*) echo "$0: invalid option: $1" >&2 + exit 1;; + + *) break;; + esac + shift done -if [ x"$src" = x ] -then - echo "install: no input file specified" - exit 1 +if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then + # When -d is used, all remaining arguments are directories to create. + # When -t is used, the destination is already specified. + # Otherwise, the last argument is the destination. Remove it from $@. + for arg + do + if test -n "$dst_arg"; then + # $@ is not empty: it contains at least $arg. + set fnord "$@" "$dst_arg" + shift # fnord + fi + shift # arg + dst_arg=$arg + done fi -if [ x"$dst" = x ] -then - echo "install: no destination specified" - exit 1 +if test $# -eq 0; then + if test -z "$dir_arg"; then + echo "$0: no input file specified." >&2 + exit 1 + fi + # It's OK to call `install-sh -d' without argument. + # This can happen when creating conditional directories. + exit 0 fi +if test -z "$dir_arg"; then + do_exit='(exit $ret); exit $ret' + trap "ret=129; $do_exit" 1 + trap "ret=130; $do_exit" 2 + trap "ret=141; $do_exit" 13 + trap "ret=143; $do_exit" 15 -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic + # Set umask so as not to create temps with too-generous modes. + # However, 'strip' requires both read and write access to temps. + case $mode in + # Optimize common cases. + *644) cp_umask=133;; + *755) cp_umask=22;; -if [ -d "$dst" ] -then - dst="$dst/`basename "$src"`" + *[0-7]) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw='% 200' + fi + cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; + *) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw=,u+rw + fi + cp_umask=$mode$u_plus_rw;; + esac fi -# Make a temp file name in the proper directory. +for src +do + # Protect names starting with `-'. + case $src in + -*) src=./$src;; + esac + + if test -n "$dir_arg"; then + dst=$src + dstdir=$dst + test -d "$dstdir" + dstdir_status=$? + else + + # Waiting for this to be detected by the "$cpprog $src $dsttmp" command + # might cause directories to be created, which would be especially bad + # if $src (and thus $dsttmp) contains '*'. + if test ! -f "$src" && test ! -d "$src"; then + echo "$0: $src does not exist." >&2 + exit 1 + fi + + if test -z "$dst_arg"; then + echo "$0: no destination specified." >&2 + exit 1 + fi + + dst=$dst_arg + # Protect names starting with `-'. + case $dst in + -*) dst=./$dst;; + esac + + # If destination is a directory, append the input filename; won't work + # if double slashes aren't ignored. + if test -d "$dst"; then + if test -n "$no_target_directory"; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 + fi + dstdir=$dst + dst=$dstdir/`basename "$src"` + dstdir_status=0 + else + # Prefer dirname, but fall back on a substitute if dirname fails. + dstdir=` + (dirname "$dst") 2>/dev/null || + expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$dst" : 'X\(//\)[^/]' \| \ + X"$dst" : 'X\(//\)$' \| \ + X"$dst" : 'X\(/\)' \| . 2>/dev/null || + echo X"$dst" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q' + ` + + test -d "$dstdir" + dstdir_status=$? + fi + fi + + obsolete_mkdir_used=false + + if test $dstdir_status != 0; then + case $posix_mkdir in + '') + # Create intermediate dirs using mode 755 as modified by the umask. + # This is like FreeBSD 'install' as of 1997-10-28. + umask=`umask` + case $stripcmd.$umask in + # Optimize common cases. + *[2367][2367]) mkdir_umask=$umask;; + .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; + + *[0-7]) + mkdir_umask=`expr $umask + 22 \ + - $umask % 100 % 40 + $umask % 20 \ + - $umask % 10 % 4 + $umask % 2 + `;; + *) mkdir_umask=$umask,go-w;; + esac + + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + case $umask in + *[123567][0-7][0-7]) + # POSIX mkdir -p sets u+wx bits regardless of umask, which + # is incompatible with FreeBSD 'install' when (umask & 300) != 0. + ;; + *) + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 -dstdir="`dirname "$dst"`" -dsttmp="$dstdir"/#inst.$$# + if (umask $mkdir_umask && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writeable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + ls_ld_tmpdir=`ls -ld "$tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/d" "$tmpdir" + else + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null + fi + trap '' 0;; + esac;; + esac + + if + $posix_mkdir && ( + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + ) + then : + else + + # The umask is ridiculous, or mkdir does not conform to POSIX, + # or it failed possibly due to a race condition. Create the + # directory the slow way, step by step, checking for races as we go. + + case $dstdir in + /*) prefix='/';; + -*) prefix='./';; + *) prefix='';; + esac + + eval "$initialize_posix_glob" + + oIFS=$IFS + IFS=/ + $posix_glob set -f + set fnord $dstdir + shift + $posix_glob set +f + IFS=$oIFS -# Move or copy the file name to the temp name + prefixes= -$doit $instcmd "$src" "$dsttmp" + for d + do + test -z "$d" && continue -# and set any options; do chmod last to preserve setuid bits + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask=$mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ + done -if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dsttmp"; fi -if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dsttmp"; fi -if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dsttmp"; fi -if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dsttmp"; fi + if test -n "$prefixes"; then + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true + fi + fi + fi -# Now rename the file to the real destination. + if test -n "$dir_arg"; then + { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && + { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || + test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 + else -$doit $rmcmd "$dst" -$doit $mvcmd "$dsttmp" "$dst" + # Make a couple of temp file names in the proper directory. + dsttmp=$dstdir/_inst.$$_ + rmtmp=$dstdir/_rm.$$_ + # Trap to clean up those temp files at exit. + trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 + + # Copy the file name to the temp name. + (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && + + # and set any options; do chmod last to preserve setuid bits. + # + # If any of these fail, we abort the whole thing. If we want to + # ignore errors from any of these, just make sure not to ignore + # errors from the above "$doit $cpprog $src $dsttmp" command. + # + { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && + { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && + { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && + + # If -C, don't bother to copy if it wouldn't change the file. + if $copy_on_change && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + + eval "$initialize_posix_glob" && + $posix_glob set -f && + set X $old && old=:$2:$4:$5:$6 && + set X $new && new=:$2:$4:$5:$6 && + $posix_glob set +f && + + test "$old" = "$new" && + $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 + then + rm -f "$dsttmp" + else + # Rename the file to the real destination. + $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || + + # The rename failed, perhaps because mv can't rename something else + # to itself, or perhaps because mv is so ancient that it does not + # support -f. + { + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd -f "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" + } + fi || exit 1 + + trap '' 0 + fi +done -exit 0 +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC" +# time-stamp-end: "; # UTC" +# End: -- cgit v0.12 From d7c58ac85de16f678822615f207d0bd806c97802 Mon Sep 17 00:00:00 2001 From: stwo Date: Tue, 7 Aug 2012 07:19:27 +0000 Subject: A little more installer consistency tweaking. --- unix/Makefile.in | 6 +++--- unix/configure | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index c369f57..4d5595d 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -894,17 +894,17 @@ install-doc: doc else true; \ fi; \ done; - @echo "Installing and cross-linking top-level (.1) docs"; + @echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.1; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \ done - @echo "Installing and cross-linking C API (.3) docs"; + @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.3; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \ done - @echo "Installing and cross-linking command (.n) docs"; + @echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.n; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \ done diff --git a/unix/configure b/unix/configure index 2e36ad2..18611f0 100755 --- a/unix/configure +++ b/unix/configure @@ -19437,8 +19437,8 @@ _ACEOF HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html' - EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' - EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we -- cgit v0.12 From 6fd899f81b0f6b242231ba10759e89f016c7b9d0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 Aug 2012 14:58:34 +0000 Subject: add 3 testcases for "dde poke", only active with --enable-symbols (we need a "dde poke" server for that, which is now built into tcldde14g.dll, but not in tcldde14.dll) --- tests/winDde.test | 21 +++++++++++++++++++++ win/tclWinDde.c | 55 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 75 insertions(+), 1 deletion(-) diff --git a/tests/winDde.test b/tests/winDde.test index 8befa3c..8d9bd12 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -15,6 +15,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +testConstraint debug [::tcl::pkgconfig get debug] testConstraint dde 0 if {[testConstraint win]} { if {![catch { @@ -166,6 +167,16 @@ test winDde-3.7 {DDE request binary} -constraints dde -body { dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00] scan [set \xe1] %c } -result 196 +test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body { + set \xe1 "" + dde poke TclEval self \xe1 \xc4 + dde request TclEval self \xe1 +} -result \xc4 +test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body { + set \xe1 "" + dde poke -binary TclEval self \xe1 \xc3\x84\x00 + dde request TclEval self \xe1 +} -result \xc4 # ------------------------------------------------------------------------- @@ -207,6 +218,16 @@ test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body { update set \xe1 } -result foo +test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body { + set \xe1 "" + set name ch\xEDld-4.5 + set child [createChildProcess $name] + dde poke TclEval $name \xe1 foo + set \xe1 [dde request TclEval $name \xe1] + dde execute TclEval $name {set done 1} + update + set \xe1 +} -result foo # ------------------------------------------------------------------------- diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 7b9fbf4..23b3a8e 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -17,7 +17,13 @@ #include #include -#ifndef UNICODE +#ifdef UNICODE +# if !defined(NDEBUG) + /* test POKE server Implemented for UNICODE in debug mode only */ +# undef CBF_FAIL_POKES +# define CBF_FAIL_POKES 0 +# endif +#else # undef CP_WINUNICODE # define CP_WINUNICODE CP_WINANSI # undef Tcl_WinTCharToUtf @@ -786,6 +792,53 @@ DdeServerProc( } return ddeReturn; +#if !CBF_FAIL_POKES + case XTYP_POKE: + /* + * This is a poke for a Tcl variable, only implemented in + * debug/UNICODE mode. + */ + ddeReturn = DDE_FNOTPROCESSED; + + if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { + return ddeReturn; + } + + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) { + Tcl_DString ds; + Tcl_Obj *variableObjPtr; + + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + Tcl_DStringInit(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + CP_WINUNICODE); + Tcl_WinTCharToUtf(utilString, -1, &ds); + utilString = (TCHAR *) DdeAccessData(hData, &dlen); + if (uFmt == CF_TEXT) { + variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); + } else { + variableObjPtr = Tcl_NewUnicodeObj(utilString, -1); + } + + Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, + variableObjPtr, TCL_GLOBAL_ONLY); + + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dString); + ddeReturn = (HDDEDATA) DDE_FACK; + } + return ddeReturn; + +#endif case XTYP_EXECUTE: { /* * Execute this script. The results will be saved into a list object -- cgit v0.12 From acc782b04789b293a45834630fc9a7d967752229 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 7 Aug 2012 15:23:27 +0000 Subject: 3554250 Overlooked one field of cleanup in the thread exit handler for the filesystem subsystem. --- ChangeLog | 5 +++++ generic/tclIOUtil.c | 1 + 2 files changed, 6 insertions(+) diff --git a/ChangeLog b/ChangeLog index 7a3b39f..9423c98 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-07 Don Porter + + * generic/tclIOUtil.c: [Bug 3554250] Overlooked one field of + cleanup in the thread exit handler for the filesystem subsystem. + 2012-07-31 Jan Nijtmans * win/nmakehlp.c: Backport from Tcl 8.6, but add -Q option from diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6cf87ad..348e7bf 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -520,6 +520,7 @@ FsThrExitProc( ckfree((char *)fsRecPtr); fsRecPtr = tmpFsRecPtr; } + tsdPtr->filesystemList = NULL; tsdPtr->initialized = 0; } -- cgit v0.12 From 031d307b32df1730b365093fd86beef232e283a6 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 7 Aug 2012 20:57:08 +0000 Subject: Minor changes to improve style (C89 declarations, consistent indentation, clarification of #endifs, reduction of unnecessary casts, use of array syntax for reading array elements, etc.) --- generic/tclCkalloc.c | 12 +- generic/tclIORChan.c | 4 +- generic/tclIOUtil.c | 9 +- generic/tclMain.c | 98 ++++--- generic/tclResult.c | 57 ++-- generic/tclUtil.c | 803 ++++++++++++++++++++++++++++++--------------------- unix/tclLoadOSF.c | 14 +- unix/tclLoadShl.c | 17 +- unix/tclUnixFile.c | 51 ++-- unix/tclUnixNotfy.c | 175 ++++++----- win/tclWinReg.c | 48 ++- 11 files changed, 746 insertions(+), 542 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 6443975..ab977cb 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -170,11 +170,15 @@ TclInitDbCkalloc(void) */ int -TclDumpMemoryInfo(ClientData clientData, int flags) +TclDumpMemoryInfo( + ClientData clientData, + int flags) { char buf[1024]; - if (clientData == NULL) { return 0; } + if (clientData == NULL) { + return 0; + } sprintf(buf, "total mallocs %10d\n" "total frees %10d\n" @@ -1255,7 +1259,9 @@ Tcl_ValidateAllMemory( } int -TclDumpMemoryInfo(ClientData clientData, int flags) +TclDumpMemoryInfo( + ClientData clientData, + int flags) { return 1; } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index a354d60..cb0282a 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1774,7 +1774,9 @@ ReflectBlock( */ static void -ReflectThread(ClientData clientData, int action) +ReflectThread( + ClientData clientData, + int action) { ReflectedChannel *rcPtr = clientData; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 4df7f36..2d6d898 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -648,23 +648,26 @@ TclFSEpochOk( } static void -Claim() +Claim(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + tsdPtr->claims++; } static void -Disclaim() +Disclaim(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + tsdPtr->claims--; } int -TclFSEpoch() +TclFSEpoch(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + return tsdPtr->filesystemEpoch; } diff --git a/generic/tclMain.c b/generic/tclMain.c index 88b4e51..14139ec 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -16,11 +16,12 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -/** - * On Windows, this file needs to be compiled twice, once with - * TCL_ASCII_MAIN defined. This way both Tcl_Main and Tcl_MainExW - * can be implemented, sharing the same source code. +/* + * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN + * defined. This way both Tcl_Main and Tcl_MainExW can be implemented, sharing + * the same source code. */ + #if defined(TCL_ASCII_MAIN) # ifdef UNICODE # undef UNICODE @@ -40,12 +41,12 @@ #define DEFAULT_PRIMARY_PROMPT "% " /* - * This file can be compiled on Windows in UNICODE mode, as well as - * on all other platforms using the native encoding. This is done - * by using the normal Windows functions like _tcscmp, but on - * platforms which don't have we have to translate that - * to strcmp here. + * This file can be compiled on Windows in UNICODE mode, as well as on all + * other platforms using the native encoding. This is done by using the normal + * Windows functions like _tcscmp, but on platforms which don't have + * we have to translate that to strcmp here. */ + #ifndef __WIN32__ # define TCHAR char # define TEXT(arg) arg @@ -128,10 +129,11 @@ typedef struct InteractiveState { MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); -static void FreeMainInterp(ClientData clientData); +static void FreeMainInterp(ClientData clientData); #ifndef TCL_ASCII_MAIN static Tcl_ThreadDataKey dataKey; + /* *---------------------------------------------------------------------- * @@ -333,8 +335,9 @@ Tcl_MainEx( if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && (TEXT('-') != argv[3][0])) { - Tcl_Obj *value = NewNativeObj(argv[2], -1); - Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value)); + Tcl_Obj *value = NewNativeObj(argv[2], -1); + Tcl_SetStartupScript(NewNativeObj(argv[3], -1), + Tcl_GetString(value)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; @@ -395,8 +398,9 @@ Tcl_MainEx( /* * Arrange for final deletion of the main interp */ - /* ARGH Munchhausen effect */ - Tcl_CreateExitHandler(FreeMainInterp, (ClientData)interp); + + /* ARGH Munchhausen effect */ + Tcl_CreateExitHandler(FreeMainInterp, interp); } /* @@ -458,6 +462,7 @@ Tcl_MainEx( mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { int length; + if (is.tty) { Prompt(interp, &is); if (Tcl_InterpDeleted(interp)) { @@ -523,7 +528,8 @@ Tcl_MainEx( Tcl_GetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); - code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); + code = Tcl_RecordAndEvalObj(interp, is.commandPtr, + TCL_EVAL_GLOBAL); is.input = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_NewObj(); @@ -557,7 +563,8 @@ Tcl_MainEx( Prompt(interp, &is); } - Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is); + Tcl_CreateChannelHandler(is.input, TCL_READABLE, + StdinProc, &is); } mainLoopProc(); @@ -568,24 +575,23 @@ Tcl_MainEx( } is.input = Tcl_GetStdChannel(TCL_STDIN); } -#ifdef TCL_MEM_DEBUG /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ +#ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { Tcl_SetMainLoop(NULL); Tcl_DeleteInterp(interp); } -#endif +#endif /* TCL_MEM_DEBUG */ } done: mainLoopProc = TclGetMainLoop(); - if ((exitCode == 0) && (mainLoopProc != NULL) - && !Tcl_LimitExceeded(interp)) { + if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, if it * exists. Packages (like Tk) can set it to start processing events at @@ -605,21 +611,21 @@ Tcl_MainEx( * exit. The Tcl_EvalObjEx call should never return. */ - if (!Tcl_InterpDeleted(interp)) { - if (!Tcl_LimitExceeded(interp)) { - Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); + if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { + Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); - Tcl_IncrRefCount(cmd); - Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(cmd); - } + Tcl_IncrRefCount(cmd); + Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmd); } - /* - * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual - * is happening. Maybe interp has been deleted; maybe [exit] was - * redefined, maybe we've blown up because of an exceeded limit. We - * still want to cleanup and exit. - */ + + /* + * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is + * happening. Maybe interp has been deleted; maybe [exit] was redefined, + * maybe we've blown up because of an exceeded limit. We still want to + * cleanup and exit. + */ + Tcl_Exit(exitCode); } @@ -637,7 +643,7 @@ Tcl_Main( Tcl_FindExecutable(argv[0]); Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); } -#endif +#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */ #ifndef TCL_ASCII_MAIN @@ -711,6 +717,7 @@ TclGetMainLoop(void) * *---------------------------------------------------------------------- */ + MODULE_SCOPE int TclFullFinalizationRequested(void) { @@ -727,7 +734,7 @@ TclFullFinalizationRequested(void) Tcl_DStringFree(&ds); } return finalize; -#endif +#endif /* PURIFY */ } #endif /* !TCL_ASCII_MAIN */ @@ -866,9 +873,8 @@ StdinProc( static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ - InteractiveState *isPtr) /* InteractiveState. Filled - * with PROMPT_NONE after a prompt is - * printed. */ + InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE + * after a prompt is printed. */ { Tcl_Obj *promptCmdPtr; int code; @@ -879,7 +885,7 @@ Prompt( } promptCmdPtr = Tcl_GetVar2Ex(interp, - ((isPtr->prompt == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), + (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { @@ -920,8 +926,8 @@ Prompt( * * FreeMainInterp -- * - * Exit handler used to cleanup the main interpreter and ancillary startup - * script storage at exit. + * Exit handler used to cleanup the main interpreter and ancillary + * startup script storage at exit. * *---------------------------------------------------------------------- */ @@ -930,13 +936,13 @@ static void FreeMainInterp( ClientData clientData) { - Tcl_Interp *interp = (Tcl_Interp *) clientData; + Tcl_Interp *interp = clientData; - /*if (TclInExit()) return;*/ + /*if (TclInExit()) return;*/ - if (!Tcl_InterpDeleted(interp)) { - Tcl_DeleteInterp(interp); - } + if (!Tcl_InterpDeleted(interp)) { + Tcl_DeleteInterp(interp); + } Tcl_SetStartupScript(NULL, NULL); Tcl_Release(interp); } diff --git a/generic/tclResult.c b/generic/tclResult.c index 17aac74..9707f20 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -380,12 +380,10 @@ Tcl_DiscardResult( if (statePtr->result == statePtr->appendResult) { ckfree(statePtr->appendResult); + } else if (statePtr->freeProc == TCL_DYNAMIC) { + ckfree(statePtr->result); } else if (statePtr->freeProc) { - if (statePtr->freeProc == TCL_DYNAMIC) { - ckfree(statePtr->result); - } else { - statePtr->freeProc(statePtr->result); - } + statePtr->freeProc(statePtr->result); } } @@ -585,7 +583,7 @@ Tcl_GetObjResult( * result, then reset the string result. */ - if (*(iPtr->result) != 0) { + if (iPtr->result[0] != 0) { ResetObjResult(iPtr); objResultPtr = iPtr->objResultPtr; @@ -601,7 +599,7 @@ Tcl_GetObjResult( iPtr->freeProc = 0; } iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; + iPtr->result[0] = 0; } return iPtr->objResultPtr; } @@ -1106,9 +1104,7 @@ Tcl_SetObjErrorCode( * * Tcl_GetErrorLine -- * - * Results: - * - * Side effects: + * Returns the line number associated with the current error. * *---------------------------------------------------------------------- */ @@ -1125,9 +1121,7 @@ Tcl_GetErrorLine( * * Tcl_SetErrorLine -- * - * Results: - * - * Side effects: + * Sets the line number associated with the current error. * *---------------------------------------------------------------------- */ @@ -1274,7 +1268,8 @@ TclProcessReturn( Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], + &valuePtr); if (valuePtr != NULL) { int infoLen; @@ -1285,7 +1280,8 @@ TclProcessReturn( iPtr->flags |= ERR_ALREADY_LOGGED; } } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], + &valuePtr); if (valuePtr != NULL) { int len, valueObjc; Tcl_Obj **valueObjv; @@ -1298,26 +1294,36 @@ TclProcessReturn( Tcl_IncrRefCount(newObj); iPtr->errorStack = newObj; } + /* * List extraction done after duplication to avoid moving the rug * if someone does [return -errorstack [info errorstack]] */ - if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { + + if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, + &valueObjv) == TCL_ERROR) { return TCL_ERROR; } iPtr->resetErrorStack = 0; Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* reset while keeping the list intrep as much as possible */ - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv); + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, + valueObjv); } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], + &valuePtr); if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } else { Tcl_SetErrorCode(interp, "NONE", NULL); } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], + &valuePtr); if (valuePtr != NULL) { TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine); } @@ -1421,7 +1427,8 @@ TclMergeReturnOptions( Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); if (valuePtr != NULL) { - if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, valuePtr, &code)) { + if (TclGetCompletionCodeFromObj(interp, valuePtr, + &code) == TCL_ERROR) { goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]); @@ -1599,7 +1606,8 @@ Tcl_GetReturnOptions( * * TclNoErrorStack -- * - * Removes the -errorstack entry from an options dict to avoid reference cycles + * Removes the -errorstack entry from an options dict to avoid reference + * cycles. * * Results: * The (unshared) argument options dict, modified in -place. @@ -1608,12 +1616,13 @@ Tcl_GetReturnOptions( */ Tcl_Obj * -TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options) +TclNoErrorStack( + Tcl_Interp *interp, + Tcl_Obj *options) { Tcl_Obj **keys = GetKeys(); Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]); - return options; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 6d42080..13e54ec 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -26,9 +26,9 @@ static ProcessGlobalValue executableName = { }; /* - * The following values are used in the flags arguments of Tcl*Scan*Element and - * Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and TCL_DONT_QUOTE_HASH - * are defined in tcl.h, like so: + * The following values are used in the flags arguments of Tcl*Scan*Element + * and Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and + * TCL_DONT_QUOTE_HASH are defined in tcl.h, like so: * #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 @@ -54,8 +54,8 @@ static ProcessGlobalValue executableName = { * conversion is most appropriate for Tcl*Convert*Element() to perform, and * sets two bits of the flags value to indicate the mode selected. * - * CONVERT_NONE The element needs no quoting. Its literal string - * is suitable as is. + * CONVERT_NONE The element needs no quoting. Its literal string is + * suitable as is. * CONVERT_BRACE The conversion should be enclosing the literal string * in braces. * CONVERT_ESCAPE The conversion should be using backslashes to escape @@ -63,19 +63,19 @@ static ProcessGlobalValue executableName = { * CONVERT_MASK A mask value used to extract the conversion mode from * the flags argument. * Also indicates a strange conversion mode where all - * special characters are escaped with backslashes - * *except for braces*. This is a strange and unnecessary + * special characters are escaped with backslashes + * *except for braces*. This is a strange and unnecessary * case, but it's part of the historical way in which - * lists have been formatted in Tcl. To experiment with + * lists have been formatted in Tcl. To experiment with * removing this case, set the value of COMPAT to 0. * - * One last flag value is used only by callers of TclScanElement(). The flag + * One last flag value is used only by callers of TclScanElement(). The flag * value produced by a call to Tcl*Scan*Element() will never leave this bit * set. * - * CONVERT_ANY The caller of TclScanElement() declares it can make - * no promise about what public flags will be passed to - * the matching call of TclConvertElement(). As such, + * CONVERT_ANY The caller of TclScanElement() declares it can make no + * promise about what public flags will be passed to the + * matching call of TclConvertElement(). As such, * TclScanElement() has to determine the worst case * destination buffer length over all possibilities, and * in other cases this means an overestimate of the @@ -129,17 +129,17 @@ const Tcl_ObjType tclEndOffsetType = { /* * * STRING REPRESENTATION OF LISTS * * * * - * The next several routines implement the conversions of strings to and - * from Tcl lists. To understand their operation, the rules of parsing - * and generating the string representation of lists must be known. Here - * we describe them in one place. + * The next several routines implement the conversions of strings to and from + * Tcl lists. To understand their operation, the rules of parsing and + * generating the string representation of lists must be known. Here we + * describe them in one place. * - * A list is made up of zero or more elements. Any string is a list if - * it is made up of alternating substrings of element-separating ASCII - * whitespace and properly formatted elements. + * A list is made up of zero or more elements. Any string is a list if it is + * made up of alternating substrings of element-separating ASCII whitespace + * and properly formatted elements. * - * The ASCII characters which can make up the whitespace between list - * elements are: + * The ASCII characters which can make up the whitespace between list elements + * are: * * \u0009 \t TAB * \u000A \n NEWLINE @@ -158,69 +158,68 @@ const Tcl_ObjType tclEndOffsetType = { * * Unlike command parsing, the BACKSLASH NEWLINE sequence is not * considered to be a whitespace character. * - * * Other Unicode whitespace characters (recognized by - * [string is space] or Tcl_UniCharIsSpace()) do not play any role - * as element separators in Tcl lists. + * * Other Unicode whitespace characters (recognized by [string is space] + * or Tcl_UniCharIsSpace()) do not play any role as element separators + * in Tcl lists. * * * The NUL byte ought not appear, as it is not in strings properly * encoded for Tcl, but if it is present, it is not treated as - * separating whitespace, or a string terminator. It is just - * another character in a list element. - * - * The interpretaton of a formatted substring as a list element follows - * rules similar to the parsing of the words of a command in a Tcl script. - * Backslash substitution plays a key role, and is defined exactly as it is - * in command parsing. The same routine, TclParseBackslash() is used in both - * command parsing and list parsing. - * - * NOTE: This means that if and when backslash substitution rules ever - * change for command parsing, the interpretation of strings as lists also - * changes. + * separating whitespace, or a string terminator. It is just another + * character in a list element. + * + * The interpretaton of a formatted substring as a list element follows rules + * similar to the parsing of the words of a command in a Tcl script. Backslash + * substitution plays a key role, and is defined exactly as it is in command + * parsing. The same routine, TclParseBackslash() is used in both command + * parsing and list parsing. + * + * NOTE: This means that if and when backslash substitution rules ever change + * for command parsing, the interpretation of strings as lists also changes. * * Backslash substitution replaces an "escape sequence" of one or more * characters starting with * \u005c \ BACKSLASH - * with a single character. The one character escape sequent case happens - * only when BACKSLASH is the last character in the string. In all other - * cases, the escape sequence is at least two characters long. + * with a single character. The one character escape sequent case happens only + * when BACKSLASH is the last character in the string. In all other cases, the + * escape sequence is at least two characters long. * - * The formatted substrings are interpreted as element values according to - * the following cases: + * The formatted substrings are interpreted as element values according to the + * following cases: * * * If the first character of a formatted substring is * \u007b { OPEN BRACE * then the end of the substring is the matching * \u007d } CLOSE BRACE - * character, where matching is determined by counting nesting levels, - * and not including any brace characters that are contained within a - * backslash escape sequence in the nesting count. Having found the - * matching brace, all characters between the braces are the string - * value of the element. If no matching close brace is found before the - * end of the string, the string is not a Tcl list. If the character - * following the close brace is not an element separating whitespace - * character, or the end of the string, then the string is not a Tcl list. - * - * NOTE: this differs from a brace-quoted word in the parsing of a - * Tcl command only in its treatment of the backslash-newline sequence. - * In a list element, the literal characters in the backslash-newline - * sequence become part of the element value. In a script word, - * conversion to a single SPACE character is done. + * character, where matching is determined by counting nesting levels, and + * not including any brace characters that are contained within a backslash + * escape sequence in the nesting count. Having found the matching brace, + * all characters between the braces are the string value of the element. + * If no matching close brace is found before the end of the string, the + * string is not a Tcl list. If the character following the close brace is + * not an element separating whitespace character, or the end of the string, + * then the string is not a Tcl list. + * + * NOTE: this differs from a brace-quoted word in the parsing of a Tcl + * command only in its treatment of the backslash-newline sequence. In a + * list element, the literal characters in the backslash-newline sequence + * become part of the element value. In a script word, conversion to a + * single SPACE character is done. * * NOTE: Most list element values can be represented by a formatted - * substring using brace quoting. The exceptions are any element value - * that includes an unbalanced brace not in a backslash escape sequence, - * and any value that ends with a backslash not itself in a backslash - * escape sequence. + * substring using brace quoting. The exceptions are any element value that + * includes an unbalanced brace not in a backslash escape sequence, and any + * value that ends with a backslash not itself in a backslash escape + * sequence. * * * If the first character of a formatted substring is * \u0022 " QUOTE * then the end of the substring is the next QUOTE character, not counting * any QUOTE characters that are contained within a backslash escape - * sequence. If no next QUOTE is found before the end of the string, the - * string is not a Tcl list. If the character following the closing QUOTE - * is not an element separating whitespace character, or the end of the - * string, then the string is not a Tcl list. Having found the limits - * of the substring, the element value is produced by performing backslash + * sequence. If no next QUOTE is found before the end of the string, the + * string is not a Tcl list. If the character following the closing QUOTE is + * not an element separating whitespace character, or the end of the string, + * then the string is not a Tcl list. Having found the limits of the + * substring, the element value is produced by performing backslash * substitution on the character sequence between the open and close QUOTEs. * * NOTE: Any element value can be represented by this style of formatting, @@ -231,7 +230,7 @@ const Tcl_ObjType tclEndOffsetType = { * of the substring, the element value is produced by performing backslash * substitution on it. * - * NOTE: Any element value can be represented by this style of formatting, + * NOTE: Any element value can be represented by this style of formatting, * given suitable choice of backslash escape sequences, with one exception. * The empty string cannot be represented as a list element without the use * of either braces or quotes to delimit it. @@ -239,32 +238,32 @@ const Tcl_ObjType tclEndOffsetType = { * This collection of parsing rules is implemented in the routine * TclFindElement(). * - * In order to produce lists that can be parsed by these rules, we need - * the ability to distinguish between characters that are part of a list - * element value from characters providing syntax that define the structure - * of the list. This means that our code that generates lists must at a - * minimum be able to produce escape sequences for the 10 characters - * identified above that have significance to a list parser. + * In order to produce lists that can be parsed by these rules, we need the + * ability to distinguish between characters that are part of a list element + * value from characters providing syntax that define the structure of the + * list. This means that our code that generates lists must at a minimum be + * able to produce escape sequences for the 10 characters identified above + * that have significance to a list parser. * - * * * CANONICAL LISTS * * * * * + * * * CANONICAL LISTS * * * * * * * In addition to the basic rules for parsing strings into Tcl lists, there * are additional properties to be met by the set of list values that are * generated by Tcl. Such list values are often said to be in "canonical * form": * - * * When any canonical list is evaluated as a Tcl script, it is a script - * of either zero commands (an empty list) or exactly one command. The - * command word is exactly the first element of the list, and each argument - * word is exactly one of the following elements of the list. This means - * that any characters that have special meaning during script evaluation - * need special treatment when canonical lists are produced: + * * When any canonical list is evaluated as a Tcl script, it is a script of + * either zero commands (an empty list) or exactly one command. The command + * word is exactly the first element of the list, and each argument word is + * exactly one of the following elements of the list. This means that any + * characters that have special meaning during script evaluation need + * special treatment when canonical lists are produced: * * * Whitespace between elements may not include NEWLINE. * * The command terminating character, * \u003b ; SEMICOLON - * must be BRACEd, QUOTEd, or escaped so that it does not terminate - * the command prematurely. + * must be BRACEd, QUOTEd, or escaped so that it does not terminate the + * command prematurely. * * Any of the characters that begin substitutions in scripts, * \u0024 $ DOLLAR * \u005b [ OPEN BRACKET @@ -274,11 +273,10 @@ const Tcl_ObjType tclEndOffsetType = { * \u0023 # HASH * that HASH character must be BRACEd, QUOTEd, or escaped so that it * does not convert the command into a comment. - * * Any list element that contains the character sequence - * BACKSLASH NEWLINE cannot be formatted with BRACEs. The - * BACKSLASH character must be represented by an escape - * sequence, and unless QUOTEs are used, the NEWLINE must - * be as well. + * * Any list element that contains the character sequence BACKSLASH + * NEWLINE cannot be formatted with BRACEs. The BACKSLASH character + * must be represented by an escape sequence, and unless QUOTEs are + * used, the NEWLINE must be as well. * * * It is also guaranteed that one can use a canonical list as a building * block of a larger script within command substitution, as in this example: @@ -289,66 +287,66 @@ const Tcl_ObjType tclEndOffsetType = { * * * Finally it is guaranteed that enclosing a canonical list in braces * produces a new value that is also a canonical list. This new list has - * length 1, and its only element is the original canonical list. This - * same guarantee also makes it possible to construct scripts where an - * argument word is given a list value by enclosing the canonical form - * of that list in braces: + * length 1, and its only element is the original canonical list. This same + * guarantee also makes it possible to construct scripts where an argument + * word is given a list value by enclosing the canonical form of that list + * in braces: * set script "puts {[list $one $two $three]}"; eval $script * This sort of coding was once fairly common, though it's become more * idiomatic to see the following instead: * set script [list puts [list $one $two $three]]; eval $script - * In order to support this guarantee, every canonical list must have + * In order to support this guarantee, every canonical list must have * balance when counting those braces that are not in escape sequences. * * Within these constraints, the canonical list generation routines - * TclScanElement() and TclConvertElement() attempt to generate the string - * for any list that is easiest to read. When an element value is itself + * TclScanElement() and TclConvertElement() attempt to generate the string for + * any list that is easiest to read. When an element value is itself * acceptable as the formatted substring, it is usually used (CONVERT_NONE). - * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) - * is usually preferred over the use of escape sequences (CONVERT_ESCAPE). - * There are some exceptions to both of these preferences for reasons of - * code simplicity, efficiency, and continuation of historical habits. - * Canonical lists never use the QUOTE formatting to delimit their elements - * because that form of quoting does not nest, which makes construction of - * nested lists far too much trouble. Canonical lists always use only a - * single SPACE character for element-separating whitespace. + * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) is + * usually preferred over the use of escape sequences (CONVERT_ESCAPE). There + * are some exceptions to both of these preferences for reasons of code + * simplicity, efficiency, and continuation of historical habits. Canonical + * lists never use the QUOTE formatting to delimit their elements because that + * form of quoting does not nest, which makes construction of nested lists far + * too much trouble. Canonical lists always use only a single SPACE character + * for element-separating whitespace. * * * * FUTURE CONSIDERATIONS * * * * * When a list element requires quoting or escaping due to a CLOSE BRACKET * character or an internal QUOTE character, a strange formatting mode is - * recommended. For example, if the value "a{b]c}d" is converted by the - * usual modes: + * recommended. For example, if the value "a{b]c}d" is converted by the usual + * modes: * * CONVERT_BRACE: a{b]c}d => {a{b]c}d} * CONVERT_ESCAPE: a{b]c}d => a\{b\]c\}d * - * we get perfectly usable formatted list elements. However, this is not - * what Tcl releases have been producing. Instead, we have: + * we get perfectly usable formatted list elements. However, this is not what + * Tcl releases have been producing. Instead, we have: * * CONVERT_MASK: a{b]c}d => a{b\]c}d * - * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same - * effect can be seen replacing ] with " in this example. There does not - * appear to be any functional or aesthetic purpose for this strange - * additional mode. The sole purpose I can see for preserving it is to - * keep generating the same formatted lists programmers have become accustomed - * to, and perhaps written tests to expect. That is, compatibility only. - * The additional code complexity required to support this mode is significant. - * The lines of code supporting it are delimited in the routines below with - * #if COMPAT directives. This makes it easy to experiment with eliminating - * this formatting mode simply with "#define COMPAT 0" above. I believe - * this is worth considering. + * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same effect + * can be seen replacing ] with " in this example. There does not appear to be + * any functional or aesthetic purpose for this strange additional mode. The + * sole purpose I can see for preserving it is to keep generating the same + * formatted lists programmers have become accustomed to, and perhaps written + * tests to expect. That is, compatibility only. The additional code + * complexity required to support this mode is significant. The lines of code + * supporting it are delimited in the routines below with #if COMPAT + * directives. This makes it easy to experiment with eliminating this + * formatting mode simply with "#define COMPAT 0" above. I believe this is + * worth considering. * - * Another consideration is the treatment of QUOTE characters in list elements. - * TclConvertElement() must have the ability to produce the escape sequence - * \" so that when a list element begins with a QUOTE we do not confuse - * that first character with a QUOTE used as list syntax to define list - * structure. However, that is the only place where QUOTE characters need - * quoting. In this way, handling QUOTE could really be much more like - * the way we handle HASH which also needs quoting and escaping only in - * particular situations. Following up this could increase the set of - * list elements that can use the CONVERT_NONE formatting mode. + * Another consideration is the treatment of QUOTE characters in list + * elements. TclConvertElement() must have the ability to produce the escape + * sequence \" so that when a list element begins with a QUOTE we do not + * confuse that first character with a QUOTE used as list syntax to define + * list structure. However, that is the only place where QUOTE characters need + * quoting. In this way, handling QUOTE could really be much more like the way + * we handle HASH which also needs quoting and escaping only in particular + * situations. Following up this could increase the set of list elements that + * can use the CONVERT_NONE formatting mode. * * More speculative is that the demands of canonical list form require brace * balance for the list as a whole, while the current implementation achieves @@ -366,15 +364,15 @@ const Tcl_ObjType tclEndOffsetType = { * * Given 'bytes' pointing to 'numBytes' bytes, scan through them and * count the number of whitespace runs that could be list element - * separators. If 'numBytes' is -1, scan to the terminating '\0'. - * Not a full list parser. Typically used to get a quick and dirty - * overestimate of length size in order to allocate space for an - * actual list parser to operate with. + * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a + * full list parser. Typically used to get a quick and dirty overestimate + * of length size in order to allocate space for an actual list parser to + * operate with. * * Results: - * Returns the largest number of list elements that could possibly - * be in this string, interpreted as a Tcl list. If 'endPtr' is not - * NULL, writes a pointer to the end of the string scanned there. + * Returns the largest number of list elements that could possibly be in + * this string, interpreted as a Tcl list. If 'endPtr' is not NULL, + * writes a pointer to the end of the string scanned there. * * Side effects: * None. @@ -395,16 +393,25 @@ TclMaxListLength( goto done; } - /* No list element before leading white space */ + /* + * No list element before leading white space. + */ + count += 1 - TclIsSpaceProc(*bytes); - /* Count white space runs as potential element separators */ + /* + * Count white space runs as potential element separators. + */ + while (numBytes) { if ((numBytes == -1) && (*bytes == '\0')) { break; } if (TclIsSpaceProc(*bytes)) { - /* Space run started; bump count */ + /* + * Space run started; bump count. + */ + count++; do { bytes++; @@ -413,16 +420,22 @@ TclMaxListLength( if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { break; } - /* (*bytes) is non-space; return to counting state */ + + /* + * (*bytes) is non-space; return to counting state. + */ } bytes++; numBytes -= (numBytes != -1); } - /* No list element following trailing white space */ + /* + * No list element following trailing white space. + */ + count -= TclIsSpaceProc(bytes[-1]); - done: + done: if (endPtr) { *endPtr = bytes; } @@ -449,18 +462,18 @@ TclMaxListLength( * that's part of the element. If this is the last argument in the list, * then *nextPtr will point just after the last character in the list * (i.e., at the character at list+listLength). If sizePtr is non-NULL, - * *sizePtr is filled in with the number of bytes in the element. If - * the element is in braces, then *elementPtr will point to the character + * *sizePtr is filled in with the number of bytes in the element. If the + * element is in braces, then *elementPtr will point to the character * after the opening brace and *sizePtr will not include either of the * braces. If there isn't an element in the list, *sizePtr will be zero, * and both *elementPtr and *nextPtr will point just after the last * character in the list. If literalPtr is non-NULL, *literalPtr is set - * to a boolean value indicating whether the substring returned as - * the values of **elementPtr and *sizePtr is the literal value of - * a list element. If not, a call to TclCopyAndCollapse() is needed - * to produce the actual value of the list element. Note: this function - * does NOT collapse backslash sequences, but uses *literalPtr to tell - * callers when it is required for them to do so. + * to a boolean value indicating whether the substring returned as the + * values of **elementPtr and *sizePtr is the literal value of a list + * element. If not, a call to TclCopyAndCollapse() is needed to produce + * the actual value of the list element. Note: this function does NOT + * collapse backslash sequences, but uses *literalPtr to tell callers + * when it is required for them to do so. * * Side effects: * None. @@ -587,9 +600,10 @@ TclFindElement( /* * A backslash sequence not within a brace quoted element * means the value of the element is different from the - * substring we are parsing. A call to TclCopyAndCollapse() - * is needed to produce the element value. Inform the caller. + * substring we are parsing. A call to TclCopyAndCollapse() is + * needed to produce the element value. Inform the caller. */ + literal = 0; } TclParseBackslash(p, limit - p, &numChars, NULL); @@ -697,9 +711,9 @@ TclFindElement( * * Results: * Count bytes get copied from src to dst. Along the way, backslash - * sequences are substituted in the copy. After scanning count bytes - * from src, a null character is placed at the end of dst. Returns - * the number of bytes that got written to dst. + * sequences are substituted in the copy. After scanning count bytes from + * src, a null character is placed at the end of dst. Returns the number + * of bytes that got written to dst. * * Side effects: * None. @@ -717,6 +731,7 @@ TclCopyAndCollapse( while (count > 0) { char c = *src; + if (c == '\\') { int numRead; int backslashCount = TclParseBackslash(src, count, &numRead, dst); @@ -780,12 +795,11 @@ Tcl_SplitList( int length, size, i, result, elSize; /* - * Allocate enough space to work in. A (const char *) for each - * (possible) list element plus one more for terminating NULL, - * plus as many bytes as in the original string value, plus one - * more for a terminating '\0'. Space used to hold element separating - * white space in the original string gets re-purposed to hold '\0' - * characters in the argv array. + * Allocate enough space to work in. A (const char *) for each (possible) + * list element plus one more for terminating NULL, plus as many bytes as + * in the original string value, plus one more for a terminating '\0'. + * Space used to hold element separating white space in the original + * string gets re-purposed to hold '\0' characters in the argv array. */ size = TclMaxListLength(list, -1, &end) + 1; @@ -844,9 +858,9 @@ Tcl_SplitList( * enclosing braces) to make the string into a valid Tcl list element. * * Results: - * The return value is an overestimate of the number of bytes that - * will be needed by Tcl_ConvertElement to produce a valid list element - * from src. The word at *flagPtr is filled in with a value needed by + * The return value is an overestimate of the number of bytes that will + * be needed by Tcl_ConvertElement to produce a valid list element from + * src. The word at *flagPtr is filled in with a value needed by * Tcl_ConvertElement when doing the actual conversion. * * Side effects: @@ -876,10 +890,10 @@ Tcl_ScanElement( * to the first null byte. * * Results: - * The return value is an overestimate of the number of bytes that - * will be needed by Tcl_ConvertCountedElement to produce a valid list - * element from src. The word at *flagPtr is filled in with a value - * needed by Tcl_ConvertCountedElement when doing the actual conversion. + * The return value is an overestimate of the number of bytes that will + * be needed by Tcl_ConvertCountedElement to produce a valid list element + * from src. The word at *flagPtr is filled in with a value needed by + * Tcl_ConvertCountedElement when doing the actual conversion. * * Side effects: * None. @@ -906,24 +920,24 @@ Tcl_ScanCountedElement( * * TclScanElement -- * - * This function is a companion function to TclConvertElement. It - * scans a string to see what needs to be done to it (e.g. add - * backslashes or enclosing braces) to make the string into a valid Tcl - * list element. If length is -1, then the string is scanned from src up - * to the first null byte. A NULL value for src is treated as an - * empty string. The incoming value of *flagPtr is a report from the - * caller what additional flags it will pass to TclConvertElement(). + * This function is a companion function to TclConvertElement. It scans a + * string to see what needs to be done to it (e.g. add backslashes or + * enclosing braces) to make the string into a valid Tcl list element. If + * length is -1, then the string is scanned from src up to the first null + * byte. A NULL value for src is treated as an empty string. The incoming + * value of *flagPtr is a report from the caller what additional flags it + * will pass to TclConvertElement(). * * Results: - * The recommended formatting mode for the element is determined and - * a value is written to *flagPtr indicating that recommendation. This + * The recommended formatting mode for the element is determined and a + * value is written to *flagPtr indicating that recommendation. This * recommendation is combined with the incoming flag values in *flagPtr * set by the caller to determine how many bytes will be needed by * TclConvertElement() in which to write the formatted element following - * the recommendation modified by the flag values. This number of bytes - * is the return value of the routine. In some situations it may be - * an overestimate, but so long as the caller passes the same flags - * to TclConvertElement(), it will be large enough. + * the recommendation modified by the flag values. This number of bytes + * is the return value of the routine. In some situations it may be an + * overestimate, but so long as the caller passes the same flags to + * TclConvertElement(), it will be large enough. * * Side effects: * None. @@ -941,7 +955,7 @@ TclScanElement( const char *p = src; int nestingLevel = 0; /* Brace nesting count */ int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something - needs protection or escape. */ + * needs protection or escape. */ int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some * reason bare or brace-quoted form fails. */ int extra = 0; /* Count of number of extra bytes needed for @@ -953,10 +967,13 @@ TclScanElement( int preferEscape = 0; /* Use preferences to track whether to use */ int preferBrace = 0; /* CONVERT_MASK mode. */ int braceCount = 0; /* Count of all braces '{' '}' seen. */ -#endif +#endif /* COMPAT */ if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { - /* Empty string element must be brace quoted. */ + /* + * Empty string element must be brace quoted. + */ + *flagPtr = CONVERT_BRACE; return 2; } @@ -966,10 +983,11 @@ TclScanElement( * Must escape or protect so leading character of value is not * misinterpreted as list element delimiting syntax. */ + forbidNone = 1; #if COMPAT preferBrace = 1; -#endif +#endif /* COMPAT */ } while (length) { @@ -978,18 +996,21 @@ TclScanElement( case '{': /* TYPE_BRACE */ #if COMPAT braceCount++; -#endif +#endif /* COMPAT */ extra++; /* Escape '{' => '\{' */ nestingLevel++; break; case '}': /* TYPE_BRACE */ #if COMPAT braceCount++; -#endif +#endif /* COMPAT */ extra++; /* Escape '}' => '\}' */ nestingLevel--; if (nestingLevel < 0) { - /* Unbalanced braces! Cannot format with brace quoting. */ + /* + * Unbalanced braces! Cannot format with brace quoting. + */ + requireEscape = 1; } break; @@ -1002,7 +1023,7 @@ TclScanElement( break; #else /* FLOW THROUGH */ -#endif +#endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ case ';': /* TYPE_COMMAND_END */ @@ -1016,18 +1037,25 @@ TclScanElement( extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; -#endif +#endif /* COMPAT */ break; case '\\': /* TYPE_SUBS */ extra++; /* Escape '\' => '\\' */ if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { - /* Final backslash. Cannot format with brace quoting. */ + /* + * Final backslash. Cannot format with brace quoting. + */ + requireEscape = 1; break; } if (p[1] == '\n') { extra++; /* Escape newline => '\n', one byte longer */ - /* Backslash newline sequence. Brace quoting not permitted. */ + + /* + * Backslash newline sequence. Brace quoting not permitted. + */ + requireEscape = 1; length -= (length > 0); p++; @@ -1041,7 +1069,7 @@ TclScanElement( forbidNone = 1; #if COMPAT preferBrace = 1; -#endif +#endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ if (length == -1) { @@ -1055,22 +1083,33 @@ TclScanElement( p++; } - endOfString: + endOfString: if (nestingLevel != 0) { - /* Unbalanced braces! Cannot format with brace quoting. */ + /* + * Unbalanced braces! Cannot format with brace quoting. + */ + requireEscape = 1; } - /* We need at least as many bytes as are in the element value... */ + /* + * We need at least as many bytes as are in the element value... + */ + bytesNeeded = p - src; if (requireEscape) { /* - * We must use escape sequences. Add all the extra bytes needed - * to have room to create them. + * We must use escape sequences. Add all the extra bytes needed to + * have room to create them. */ + bytesNeeded += extra; - /* Make room to escape leading #, if needed. */ + + /* + * Make room to escape leading #, if needed. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } @@ -1080,12 +1119,13 @@ TclScanElement( if (*flagPtr & CONVERT_ANY) { /* * The caller has not let us know what flags it will pass to - * TclConvertElement() so compute the max size we might need for - * any possible choice. Normally the formatting using escape - * sequences is the longer one, and a minimum "extra" value of 2 - * makes sure we don't request too small a buffer in those edge - * cases where that's not true. + * TclConvertElement() so compute the max size we might need for any + * possible choice. Normally the formatting using escape sequences is + * the longer one, and a minimum "extra" value of 2 makes sure we + * don't request too small a buffer in those edge cases where that's + * not true. */ + if (extra < 2) { extra = 2; } @@ -1093,59 +1133,78 @@ TclScanElement( *flagPtr |= TCL_DONT_USE_BRACES; } if (forbidNone) { - /* We must request some form of quoting of escaping... */ + /* + * We must request some form of quoting of escaping... + */ + #if COMPAT if (preferEscape && !preferBrace) { /* - * If we are quoting solely due to ] or internal " characters - * use the CONVERT_MASK mode where we escape all special - * characters except for braces. "extra" counted space needed - * to escape braces too, so substract "braceCount" to get our - * actual needs. + * If we are quoting solely due to ] or internal " characters use + * the CONVERT_MASK mode where we escape all special characters + * except for braces. "extra" counted space needed to escape + * braces too, so substract "braceCount" to get our actual needs. */ + bytesNeeded += (extra - braceCount); /* Make room to escape leading #, if needed. */ if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } + /* * If the caller reports it will direct TclConvertElement() to * use full escapes on the element, add back the bytes needed to * escape the braces. */ + if (*flagPtr & TCL_DONT_USE_BRACES) { bytesNeeded += braceCount; } *flagPtr = CONVERT_MASK; goto overflowCheck; } -#endif +#endif /* COMPAT */ if (*flagPtr & TCL_DONT_USE_BRACES) { /* * If the caller reports it will direct TclConvertElement() to * use escapes, add the extra bytes needed to have room for them. */ + bytesNeeded += extra; - /* Make room to escape leading #, if needed. */ + + /* + * Make room to escape leading #, if needed. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } } else { - /* Add 2 bytes for room for the enclosing braces. */ + /* + * Add 2 bytes for room for the enclosing braces. + */ + bytesNeeded += 2; } *flagPtr = CONVERT_BRACE; goto overflowCheck; } - /* So far, no need to quote or escape anything. */ + /* + * So far, no need to quote or escape anything. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { - /* If we need to quote a leading #, make room to enclose in braces. */ + /* + * If we need to quote a leading #, make room to enclose in braces. + */ + bytesNeeded += 2; } *flagPtr = CONVERT_NONE; - overflowCheck: + overflowCheck: if (bytesNeeded < 0) { Tcl_Panic("TclScanElement: string length overflow"); } @@ -1220,9 +1279,9 @@ Tcl_ConvertCountedElement( * * TclConvertElement -- * - * This is a companion function to TclScanElement. Given the - * information produced by TclScanElement, this function converts - * a string to a list element equal to that string. + * This is a companion function to TclScanElement. Given the information + * produced by TclScanElement, this function converts a string to a list + * element equal to that string. * * Results: * Information is copied to *dst in the form of a list element identical @@ -1236,7 +1295,8 @@ Tcl_ConvertCountedElement( *---------------------------------------------------------------------- */ -int TclConvertElement( +int +TclConvertElement( register const char *src, /* Source information for list element. */ int length, /* Number of bytes in src, or -1. */ char *dst, /* Place to put list-ified element. */ @@ -1245,19 +1305,28 @@ int TclConvertElement( int conversion = flags & CONVERT_MASK; char *p = dst; - /* Let the caller demand we use escape sequences rather than braces. */ + /* + * Let the caller demand we use escape sequences rather than braces. + */ + if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) { conversion = CONVERT_ESCAPE; } - /* No matter what the caller demands, empty string must be braced! */ - if ((src == NULL) || (length == 0) || ((*src == '\0') && (length == -1))) { + /* + * No matter what the caller demands, empty string must be braced! + */ + + if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { src = tclEmptyStringRep; length = 0; conversion = CONVERT_BRACE; } - /* Escape leading hash as needed and requested. */ + /* + * Escape leading hash as needed and requested. + */ + if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { if (conversion == CONVERT_ESCAPE) { p[0] = '\\'; @@ -1270,7 +1339,10 @@ int TclConvertElement( } } - /* No escape or quoting needed. Copy the literal string value. */ + /* + * No escape or quoting needed. Copy the literal string value. + */ + if (conversion == CONVERT_NONE) { if (length == -1) { /* TODO: INT_MAX overflow? */ @@ -1284,7 +1356,10 @@ int TclConvertElement( } } - /* Formatted string is original string enclosed in braces. */ + /* + * Formatted string is original string enclosed in braces. + */ + if (conversion == CONVERT_BRACE) { *p = '{'; p++; @@ -1304,7 +1379,10 @@ int TclConvertElement( /* conversion == CONVERT_ESCAPE or CONVERT_MASK */ - /* Formatted string is original string converted to escape sequences. */ + /* + * Formatted string is original string converted to escape sequences. + */ + for ( ; length; src++, length -= (length > 0)) { switch (*src) { case ']': @@ -1320,13 +1398,12 @@ int TclConvertElement( case '{': case '}': #if COMPAT - if (conversion == CONVERT_ESCAPE) { -#endif + if (conversion == CONVERT_ESCAPE) +#endif /* COMPAT */ + { *p = '\\'; p++; -#if COMPAT } -#endif break; case '\f': *p = '\\'; @@ -1362,13 +1439,15 @@ int TclConvertElement( if (length == -1) { return p - dst; } + /* - * If we reach this point, there's an embedded NULL in the - * string range being processed, which should not happen when - * the encoding rules for Tcl strings are properly followed. - * If the day ever comes when we stop tolerating such things, - * this is where to put the Tcl_Panic(). + * If we reach this point, there's an embedded NULL in the string + * range being processed, which should not happen when the + * encoding rules for Tcl strings are properly followed. If the + * day ever comes when we stop tolerating such things, this is + * where to put the Tcl_Panic(). */ + break; } *p = *src; @@ -1402,17 +1481,18 @@ Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { -# define LOCAL_SIZE 20 +#define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; int i, bytesNeeded = 0; char *result, *dst; const int maxFlags = UINT_MAX / sizeof(int); + /* + * Handle empty list case first, so logic of the general case can be + * simpler. + */ + if (argc == 0) { - /* - * Handle empty list case first, so logic of the general case - * can be simpler. - */ result = ckalloc(1); result[0] = '\0'; return result; @@ -1426,17 +1506,17 @@ Tcl_Merge( flagPtr = localFlags; } else if (argc > maxFlags) { /* - * We cannot allocate a large enough flag array to format this - * list in one pass. We could imagine converting this routine - * to a multi-pass implementation, but for sizeof(int) == 4, - * the limit is a max of 2^30 list elements and since each element - * is at least one byte formatted, and requires one byte space - * between it and the next one, that a minimum space requirement - * of 2^31 bytes, which is already INT_MAX. If we tried to format - * a list of > maxFlags elements, we're just going to overflow - * the size limits on the formatted string anyway, so just issue - * that same panic early. + * We cannot allocate a large enough flag array to format this list in + * one pass. We could imagine converting this routine to a multi-pass + * implementation, but for sizeof(int) == 4, the limit is a max of + * 2^30 list elements and since each element is at least one byte + * formatted, and requires one byte space between it and the next one, + * that a minimum space requirement of 2^31 bytes, which is already + * INT_MAX. If we tried to format a list of > maxFlags elements, we're + * just going to overflow the size limits on the formatted string + * anyway, so just issue that same panic early. */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { flagPtr = ckalloc(argc * sizeof(int)); @@ -1511,9 +1591,10 @@ Tcl_Backslash( *---------------------------------------------------------------------- * * TclTrimRight -- - * Takes two counted strings in the Tcl encoding which must both be - * null terminated. Conceptually trims from the right side of the - * first string all characters found in the second string. + * + * Takes two counted strings in the Tcl encoding which must both be null + * terminated. Conceptually trims from the right side of the first string + * all characters found in the second string. * * Results: * The number of bytes to be removed from the end of the string. @@ -1526,10 +1607,10 @@ Tcl_Backslash( int TclTrimRight( - const char *bytes, /* String to be trimmed... */ - int numBytes, /* ...and its length in bytes */ - const char *trim, /* String of trim characters... */ - int numTrim) /* ...and its length in bytes */ + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ { const char *p = bytes + numBytes; int pInc; @@ -1538,12 +1619,18 @@ TclTrimRight( Tcl_Panic("TclTrimRight works only on null-terminated strings"); } - /* Empty strings -> nothing to do */ + /* + * Empty strings -> nothing to do. + */ + if ((numBytes == 0) || (numTrim == 0)) { return 0; } - /* Outer loop: iterate over string to be trimmed */ + /* + * Outer loop: iterate over string to be trimmed. + */ + do { Tcl_UniChar ch1; const char *q = trim; @@ -1552,7 +1639,10 @@ TclTrimRight( p = Tcl_UtfPrev(p, bytes); pInc = TclUtfToUniChar(p, &ch1); - /* Inner loop: scan trim string for match to current character */ + /* + * Inner loop: scan trim string for match to current character. + */ + do { Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); @@ -1566,7 +1656,10 @@ TclTrimRight( } while (bytesLeft); if (bytesLeft == 0) { - /* No match; trim task done; *p is last non-trimmed char */ + /* + * No match; trim task done; *p is last non-trimmed char. + */ + p += pInc; break; } @@ -1579,9 +1672,10 @@ TclTrimRight( *---------------------------------------------------------------------- * * TclTrimLeft -- - * Takes two counted strings in the Tcl encoding which must both be - * null terminated. Conceptually trims from the left side of the - * first string all characters found in the second string. + * + * Takes two counted strings in the Tcl encoding which must both be null + * terminated. Conceptually trims from the left side of the first string + * all characters found in the second string. * * Results: * The number of bytes to be removed from the start of the string. @@ -1594,10 +1688,10 @@ TclTrimRight( int TclTrimLeft( - const char *bytes, /* String to be trimmed... */ - int numBytes, /* ...and its length in bytes */ - const char *trim, /* String of trim characters... */ - int numTrim) /* ...and its length in bytes */ + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ { const char *p = bytes; @@ -1605,19 +1699,28 @@ TclTrimLeft( Tcl_Panic("TclTrimLeft works only on null-terminated strings"); } - /* Empty strings -> nothing to do */ + /* + * Empty strings -> nothing to do. + */ + if ((numBytes == 0) || (numTrim == 0)) { return 0; } - /* Outer loop: iterate over string to be trimmed */ + /* + * Outer loop: iterate over string to be trimmed. + */ + do { Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; - /* Inner loop: scan trim string for match to current character */ + /* + * Inner loop: scan trim string for match to current character. + */ + do { Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); @@ -1631,7 +1734,10 @@ TclTrimLeft( } while (bytesLeft); if (bytesLeft == 0) { - /* No match; trim task done; *p is first non-trimmed char */ + /* + * No match; trim task done; *p is first non-trimmed char. + */ + break; } @@ -1673,14 +1779,20 @@ Tcl_Concat( int i, needSpace = 0, bytesNeeded = 0; char *result, *p; - /* Dispose of the empty result corner case first to simplify later code */ + /* + * Dispose of the empty result corner case first to simplify later code. + */ + if (argc == 0) { result = (char *) ckalloc(1); result[0] = '\0'; return result; } - /* First allocate the result buffer at the size required */ + /* + * First allocate the result buffer at the size required. + */ + for (i = 0; i < argc; i++) { bytesNeeded += strlen(argv[i]); if (bytesNeeded < 0) { @@ -1689,13 +1801,18 @@ Tcl_Concat( } if (bytesNeeded + argc - 1 < 0) { /* - * Panic test could be tighter, but not going to bother for - * this legacy routine. + * Panic test could be tighter, but not going to bother for this + * legacy routine. */ + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } - /* All element bytes + (argc - 1) spaces + 1 terminating NULL */ - result = (char *) ckalloc((unsigned) (bytesNeeded + argc)); + + /* + * All element bytes + (argc - 1) spaces + 1 terminating NULL. + */ + + result = ckalloc((unsigned) (bytesNeeded + argc)); for (p = result, i = 0; i < argc; i++) { int trim, elemLength; @@ -1704,26 +1821,35 @@ Tcl_Concat( element = argv[i]; elemLength = strlen(argv[i]); - /* Trim away the leading whitespace */ + /* + * Trim away the leading whitespace. + */ + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); element += trim; elemLength -= trim; /* - * Trim away the trailing whitespace. Do not permit trimming - * to expose a final backslash character. + * Trim away the trailing whitespace. Do not permit trimming to expose + * a final backslash character. */ trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; - /* If we're left with empty element after trimming, do nothing */ + /* + * If we're left with empty element after trimming, do nothing. + */ + if (elemLength == 0) { continue; } - /* Append to the result with space if needed */ + /* + * Append to the result with space if needed. + */ + if (needSpace) { *p++ = ' '; } @@ -1802,9 +1928,10 @@ Tcl_ConcatObj( /* * Something cannot be determined to be safe, so build the concatenation * the slow way, using the string representations. + * + * First try to pre-allocate the size required. */ - /* First try to pre-allocate the size required */ for (i = 0; i < objc; i++) { element = TclGetStringFromObj(objv[i], &elemLength); bytesNeeded += elemLength; @@ -1812,11 +1939,13 @@ Tcl_ConcatObj( break; } } + /* - * Does not matter if this fails, will simply try later to build up - * the string with each Append reallocating as needed with the usual - * string append algorithm. When that fails it will report the error. + * Does not matter if this fails, will simply try later to build up the + * string with each Append reallocating as needed with the usual string + * append algorithm. When that fails it will report the error. */ + TclNewObj(resPtr); Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); Tcl_SetObjLength(resPtr, 0); @@ -1826,26 +1955,35 @@ Tcl_ConcatObj( element = TclGetStringFromObj(objv[i], &elemLength); - /* Trim away the leading whitespace */ + /* + * Trim away the leading whitespace. + */ + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); element += trim; elemLength -= trim; /* - * Trim away the trailing whitespace. Do not permit trimming - * to expose a final backslash character. + * Trim away the trailing whitespace. Do not permit trimming to expose + * a final backslash character. */ trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; - /* If we're left with empty element after trimming, do nothing */ + /* + * If we're left with empty element after trimming, do nothing. + */ + if (elemLength == 0) { continue; } - /* Append to the result with space if needed */ + /* + * Append to the result with space if needed. + */ + if (needSpace) { Tcl_AppendToObj(resPtr, " ", 1); } @@ -2249,6 +2387,7 @@ TclByteArrayMatch( /* * Matches ranges of form [a-z] or [z-a]. */ + break; } } else if (startChar == ch1) { @@ -2295,9 +2434,9 @@ TclByteArrayMatch( * * TclStringMatchObj -- * - * See if a particular string matches a particular pattern. - * Allows case insensitivity. This is the generic multi-type handler - * for the various matching algorithms. + * See if a particular string matches a particular pattern. Allows case + * insensitivity. This is the generic multi-type handler for the various + * matching algorithms. * * Results: * The return value is 1 if string matches pattern, and 0 otherwise. The @@ -2657,24 +2796,8 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Interp *iPtr = (Interp *) interp; - Tcl_ResetResult(interp); - - if (dsPtr->string != dsPtr->staticSpace) { - iPtr->result = dsPtr->string; - iPtr->freeProc = TCL_DYNAMIC; - } else if (dsPtr->length < TCL_RESULT_SIZE) { - iPtr->result = iPtr->resultSpace; - memcpy(iPtr->result, dsPtr->string, dsPtr->length + 1); - } else { - Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); - } - - dsPtr->string = dsPtr->staticSpace; - dsPtr->length = 0; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->staticSpace[0] = '\0'; + Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } /* @@ -2710,6 +2833,39 @@ Tcl_DStringGetResult( } /* + * Do more efficient transfer when we know the result is a Tcl_Obj. When + * there's no st`ring result, we only have to deal with two cases: + * + * 1. When the string rep is the empty string, when we don't copy but + * instead use the staticSpace in the DString to hold an empty string. + + * 2. When the string rep is not there or there's a real string rep, when + * we use Tcl_GetString to fetch (or generate) the string rep - which + * we know to have been allocated with ckalloc() - and use it to + * populate the DString space. Then, we free the internal rep. and set + * the object's string representation back to the canonical empty + * string. + */ + + if (!iPtr->result[0] && iPtr->objResultPtr + && !Tcl_IsShared(iPtr->objResultPtr)) { + if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->string[0] = 0; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = Tcl_GetString(iPtr->objResultPtr); + dsPtr->length = iPtr->objResultPtr->length; + dsPtr->spaceAvl = dsPtr->length + 1; + TclFreeIntRep(iPtr->objResultPtr); + iPtr->objResultPtr->bytes = tclEmptyStringRep; + iPtr->objResultPtr->length = 0; + } + return; + } + + /* * If the string result is empty, move the object result to the string * result, then reset the object result. */ @@ -2947,12 +3103,12 @@ Tcl_PrintDouble( * Tcl 8.4 implements the first of these, which gives rise to * anomalies in formatting: * - * % expr 0.1 - * 0.10000000000000001 - * % expr 0.01 - * 0.01 - * % expr 1e-7 - * 9.9999999999999995e-08 + * % expr 0.1 + * 0.10000000000000001 + * % expr 0.01 + * 0.01 + * % expr 1e-7 + * 9.9999999999999995e-08 * * For human readability, it appears better to choose the second rule, * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer @@ -2965,8 +3121,8 @@ Tcl_PrintDouble( */ digits = TclDoubleDigits(value, *precisionPtr, - TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, - &exponent, &signum, &end); + TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, + &exponent, &signum, &end); } if (signum) { *dst++ = '-'; @@ -3222,10 +3378,10 @@ TclNeedSpace( */ int -TclFormatInt(buffer, n) - char *buffer; /* Points to the storage into which the +TclFormatInt( + char *buffer, /* Points to the storage into which the * formatted characters are written. */ - long n; /* The integer to format. */ + long n) /* The integer to format. */ { long intVal; int i; @@ -3243,9 +3399,9 @@ TclFormatInt(buffer, n) } /* - * Check whether "n" is the maximum negative value. This is - * -2^(m-1) for an m-bit word, and has no positive equivalent; - * negating it produces the same value. + * Check whether "n" is the maximum negative value. This is -2^(m-1) for + * an m-bit word, and has no positive equivalent; negating it produces the + * same value. */ intVal = -n; /* [Bug 3390638] Workaround for*/ @@ -3277,6 +3433,7 @@ TclFormatInt(buffer, n) for (j = 0; j < i; j++, i--) { char tmp = buffer[i]; + buffer[i] = buffer[j]; buffer[j] = tmp; } @@ -3742,7 +3899,7 @@ TclSetProcessGlobalValue( if (NULL != pgvPtr->value) { ckfree(pgvPtr->value); } else { - Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); + Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index 6515b89..6e76b55 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -35,12 +35,14 @@ #include "tclInt.h" #include #include - -/* Static functions defined within this file */ -static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, - const char* symbol); -static void UnloadFile(Tcl_LoadHandle handle); +/* + * Static functions defined within this file. + */ + +static void * FindSymbol(Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, const char* symbol); +static void UnloadFile(Tcl_LoadHandle handle); /* *---------------------------------------------------------------------- @@ -105,7 +107,7 @@ TclpDlopen( if (lm == LDR_NULL_MODULE) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load file \"%s\": %s", - fileName, Tcl_PosixError(interp)); + fileName, Tcl_PosixError(interp))); return TCL_ERROR; } diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index 968f232..7b80bcc 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -22,14 +22,14 @@ #endif #include "tclInt.h" - -/* Static functions defined within this file */ -static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, - const char* symbol); -static void -UnloadFile(Tcl_LoadHandle handle); +/* + * Static functions defined within this file. + */ +static void * FindSymbol(Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, const char *symbol); +static void UnloadFile(Tcl_LoadHandle handle); /* *---------------------------------------------------------------------- @@ -137,7 +137,7 @@ FindSymbol( { Tcl_DString newName; Tcl_PackageInitProc *proc = NULL; - shl_t handle = (shl_t)(loadHandle->clientData); + shl_t handle = (shl_t) loadHandle->clientData; /* * Some versions of the HP system software still use "_" at the beginning @@ -187,9 +187,8 @@ UnloadFile( * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { - shl_t handle; + shl_t handle = (shl_t) loadHandle->clientData; - handle = (shl_t) (loadHandle -> clientData); shl_unload(handle); ckfree(loadHandle); } diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 01fc6fe..38504d9 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -470,7 +470,7 @@ NativeMatchType( #ifndef MAC_OSX_TCL || ((types->perm & TCL_GLOB_PERM_HIDDEN) && (*nativeName != '.')) -#endif +#endif /* MAC_OSX_TCL */ ) { return 0; } @@ -488,12 +488,10 @@ NativeMatchType( * check that here: */ - if (types->type & TCL_GLOB_TYPE_LINK) { - if (TclOSlstat(nativeEntry, &buf) == 0) { - if (S_ISLNK(buf.st_mode)) { - return 1; - } - } + if ((types->type & TCL_GLOB_TYPE_LINK) + && (TclOSlstat(nativeEntry, &buf) == 0) + && S_ISLNK(buf.st_mode)) { + return 1; } return 0; } @@ -516,12 +514,10 @@ NativeMatchType( */ } else { #ifdef S_ISLNK - if (types->type & TCL_GLOB_TYPE_LINK) { - if (TclOSlstat(nativeEntry, &buf) == 0) { - if (S_ISLNK(buf.st_mode)) { - goto filetypeOK; - } - } + if ((types->type & TCL_GLOB_TYPE_LINK) + && (TclOSlstat(nativeEntry, &buf) == 0) + && S_ISLNK(buf.st_mode)) { + goto filetypeOK; } #endif /* S_ISLNK */ return 0; @@ -717,9 +713,9 @@ TclpGetNativeCwd( if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */ return NULL; } -#endif +#endif /* USEGETWD */ - if ((clientData == NULL) || strcmp(buffer, (const char*)clientData)) { + if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) { char *newCd = ckalloc(strlen(buffer) + 1); strcpy(newCd, buffer); @@ -767,7 +763,7 @@ TclpGetCwd( if (getwd(buffer) == NULL) /* INTL: Native. */ #else if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */ -#endif +#endif /* USEGETWD */ { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -823,7 +819,7 @@ TclpReadlink( return Tcl_DStringValue(linkPtr); #else return NULL; -#endif +#endif /* !DJGPP */ } /* @@ -857,7 +853,7 @@ TclpObjStat( #ifdef S_IFLNK -Tcl_Obj* +Tcl_Obj * TclpObjLink( Tcl_Obj *pathPtr, Tcl_Obj *toPtr, @@ -1179,10 +1175,17 @@ TclpUtime( { return utime(Tcl_FSGetNativePath(pathPtr), tval); } + #ifdef __CYGWIN__ -int TclOSstat(const char *name, Tcl_StatBuf *statBuf) { + +int +TclOSstat( + const char *name, + Tcl_StatBuf *statBuf) +{ struct stat buf; int result = stat(name, &buf); + statBuf->st_mode = buf.st_mode; statBuf->st_ino = buf.st_ino; statBuf->st_dev = buf.st_dev; @@ -1196,9 +1199,15 @@ int TclOSstat(const char *name, Tcl_StatBuf *statBuf) { statBuf->st_ctime = buf.st_ctime; return result; } -int TclOSlstat(const char *name, Tcl_StatBuf *statBuf) { + +int +TclOSlstat( + const char *name, + Tcl_StatBuf *statBuf) +{ struct stat buf; int result = lstat(name, &buf); + statBuf->st_mode = buf.st_mode; statBuf->st_ino = buf.st_ino; statBuf->st_dev = buf.st_dev; @@ -1212,7 +1221,7 @@ int TclOSlstat(const char *name, Tcl_StatBuf *statBuf) { statBuf->st_ctime = buf.st_ctime; return result; } -#endif +#endif /* CYGWIN */ /* * Local Variables: diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index ca95f40..b87af1b 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -96,7 +96,7 @@ typedef struct ThreadSpecificData { * that an event is ready to be processed * by sending this event. */ void *hwnd; /* Messaging window. */ -#else /* !__CYGWIN__ */ +#else Tcl_Condition waitCV; /* Any other thread alerts a notifier that an * event is ready to be processed by signaling * this condition variable. */ @@ -104,7 +104,7 @@ typedef struct ThreadSpecificData { int eventReady; /* True if an event is ready to be processed. * Used as condition flag together with waitCV * above. */ -#endif +#endif /* TCL_THREADS */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -187,25 +187,12 @@ static Tcl_ThreadId notifierThread; static void NotifierThreadProc(ClientData clientData); #endif static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); - + /* - *---------------------------------------------------------------------- - * - * Tcl_InitNotifier -- - * - * Initializes the platform specific notifier state. - * - * Results: - * Returns a handle to the notifier state for this thread. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- + * Import of Windows API when building threaded with Cygwin. */ #if defined(TCL_THREADS) && defined(__CYGWIN__) - typedef struct { void *hwnd; unsigned int *message; @@ -217,34 +204,60 @@ typedef struct { } MSG; typedef struct { - unsigned int style; - void *lpfnWndProc; - int cbClsExtra; - int cbWndExtra; - void *hInstance; - void *hIcon; - void *hCursor; - void *hbrBackground; - void *lpszMenuName; - void *lpszClassName; + unsigned int style; + void *lpfnWndProc; + int cbClsExtra; + int cbWndExtra; + void *hInstance; + void *hIcon; + void *hCursor; + void *hbrBackground; + void *lpszMenuName; + void *lpszClassName; } WNDCLASS; -extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int); -extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int); -extern unsigned char __stdcall TranslateMessage(const MSG *); -extern int __stdcall DispatchMessageW(const MSG *); -extern void __stdcall PostQuitMessage(int); -extern void * __stdcall CreateWindowExW(void *, void *, void *, DWORD, int, int, int, int, void *, void *, void *, void *); -extern unsigned char __stdcall DestroyWindow(void *); -extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *, void *); -extern void *__stdcall RegisterClassW(const WNDCLASS *); -extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *); -extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char, void *); -extern void __stdcall CloseHandle(void *); -extern void __stdcall MsgWaitForMultipleObjects(DWORD, void *, unsigned char, DWORD, DWORD); -extern unsigned char __stdcall ResetEvent(void *); +extern void __stdcall CloseHandle(void *); +extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char, + void *); +extern void * __stdcall CreateWindowExW(void *, void *, void *, DWORD, int, + int, int, int, void *, void *, void *, void *); +extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *); +extern unsigned char __stdcall DestroyWindow(void *); +extern int __stdcall DispatchMessageW(const MSG *); +extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int); +extern void __stdcall MsgWaitForMultipleObjects(DWORD, void *, + unsigned char, DWORD, DWORD); +extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int); +extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *, + void *); +extern void __stdcall PostQuitMessage(int); +extern void *__stdcall RegisterClassW(const WNDCLASS *); +extern unsigned char __stdcall ResetEvent(void *); +extern unsigned char __stdcall TranslateMessage(const MSG *); -#endif +/* + * Threaded-cygwin specific functions in this file: + */ + +static DWORD __stdcall NotifierProc(void *hwnd, unsigned int message, + void *wParam, void *lParam); +#endif /* TCL_THREADS && __CYGWIN__ */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitNotifier -- + * + * Initializes the platform specific notifier state. + * + * Results: + * Returns a handle to the notifier state for this thread. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ ClientData Tcl_InitNotifier(void) @@ -403,11 +416,11 @@ Tcl_AlertNotifier( Tcl_MutexLock(¬ifierMutex); tsdPtr->eventReady = 1; -#ifdef __CYGWIN__ +# ifdef __CYGWIN__ PostMessageW(tsdPtr->hwnd, 1024, 0, 0); -#else +# else Tcl_ConditionNotify(&tsdPtr->waitCV); -#endif +# endif /* __CYGWIN__ */ Tcl_MutexUnlock(¬ifierMutex); #endif /* TCL_THREADS */ } @@ -732,12 +745,12 @@ NotifierProc( * Process all of the runnable events. */ - tsdPtr->eventReady = 1; + tsdPtr->eventReady = 1; Tcl_ServiceAll(); return 0; } -#endif /* __CYGWIN__ */ - +#endif /* TCL_THREADS && __CYGWIN__ */ + /* *---------------------------------------------------------------------- * @@ -768,9 +781,9 @@ Tcl_WaitForEvent( Tcl_Time vTime; #ifdef TCL_THREADS int waitForFiles; -# ifdef __CYGWIN__ - MSG msg; -# endif +# ifdef __CYGWIN__ + MSG msg; +# endif /* __CYGWIN__ */ #else /* * Impl. notes: timeout & timeoutPtr are used if, and only if threads @@ -792,8 +805,8 @@ Tcl_WaitForEvent( if (timePtr != NULL) { /* * TIP #233 (Virtualized Time). Is virtual time in effect? And do - * we actually have something to scale? If yes to both then we call - * the handler to do this scaling. + * we actually have something to scale? If yes to both then we + * call the handler to do this scaling. */ if (timePtr->sec != 0 || timePtr->usec != 0) { @@ -807,17 +820,17 @@ Tcl_WaitForEvent( timeoutPtr = &timeout; } else if (tsdPtr->numFdBits == 0) { /* - * If there are no threads, no timeout, and no fds registered, then - * there are no events possible and we must avoid deadlock. Note - * that this is not entirely correct because there might be a - * signal that could interrupt the select call, but we don't handle - * that case if we aren't using threads. + * If there are no threads, no timeout, and no fds registered, + * then there are no events possible and we must avoid deadlock. + * Note that this is not entirely correct because there might be a + * signal that could interrupt the select call, but we don't + * handle that case if we aren't using threads. */ return -1; } else { timeoutPtr = NULL; -#endif /* TCL_THREADS */ +#endif /* !TCL_THREADS */ } #ifdef TCL_THREADS @@ -828,7 +841,7 @@ Tcl_WaitForEvent( #ifdef __CYGWIN__ if (!tsdPtr->hwnd) { - WNDCLASS class; + WNDCLASS class; class.style = 0; class.cbClsExtra = 0; @@ -842,24 +855,24 @@ Tcl_WaitForEvent( class.hCursor = NULL; RegisterClassW(&class); - tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName, class.lpszClassName, - 0, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); + tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName, + class.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL, + TclWinGetTclInstance(), NULL); tsdPtr->event = CreateEventW(NULL, 1 /* manual */, 0 /* !signaled */, NULL); - } - -#endif + } +#endif /* __CYGWIN */ Tcl_MutexLock(¬ifierMutex); if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0 #if defined(__APPLE__) && defined(__LP64__) /* - * On 64-bit Darwin, pthread_cond_timedwait() appears to have a - * bug that causes it to wait forever when passed an absolute - * time which has already been exceeded by the system time; as - * a workaround, when given a very brief timeout, just do a - * poll. [Bug 1457797] + * On 64-bit Darwin, pthread_cond_timedwait() appears to have + * a bug that causes it to wait forever when passed an + * absolute time which has already been exceeded by the system + * time; as a workaround, when given a very brief timeout, + * just do a poll. [Bug 1457797] */ || timePtr->usec < 10 #endif /* __APPLE__ && __LP64__ */ @@ -883,8 +896,8 @@ Tcl_WaitForEvent( if (waitForFiles) { /* * Add the ThreadSpecificData structure of this thread to the list - * of ThreadSpecificData structures of all threads that are waiting - * on file events. + * of ThreadSpecificData structures of all threads that are + * waiting on file events. */ tsdPtr->nextPtr = waitingListPtr; @@ -909,6 +922,7 @@ Tcl_WaitForEvent( #ifdef __CYGWIN__ if (!PeekMessageW(&msg, NULL, 0, 0, 0)) { DWORD timeout; + if (timePtr) { timeout = timePtr->sec * 1000 + timePtr->usec / 1000; } else { @@ -920,7 +934,7 @@ Tcl_WaitForEvent( } #else Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr); -#endif +#endif /* __CYGWIN__ */ } tsdPtr->eventReady = 0; @@ -929,17 +943,20 @@ Tcl_WaitForEvent( /* * Retrieve and dispatch the message. */ + DWORD result = GetMessageW(&msg, NULL, 0, 0); + if (result == 0) { PostQuitMessage(msg.wParam); /* What to do here? */ - } else if (result != (DWORD)-1) { + } else if (result != (DWORD) -1) { TranslateMessage(&msg); DispatchMessageW(&msg); } } ResetEvent(tsdPtr->event); -#endif +#endif /* __CYGWIN__ */ + if (waitForFiles && tsdPtr->onList) { /* * Remove the ThreadSpecificData structure of this thread from the @@ -1211,9 +1228,9 @@ NotifierThreadProc( tsdPtr->pollState = 0; } #ifdef __CYGWIN__ - PostMessageW(tsdPtr->hwnd, 1024, 0, 0); -#else /* __CYGWIN__ */ - Tcl_ConditionNotify(&tsdPtr->waitCV); + PostMessageW(tsdPtr->hwnd, 1024, 0, 0); +#else + Tcl_ConditionNotify(&tsdPtr->waitCV); #endif /* __CYGWIN__ */ } } @@ -1255,7 +1272,7 @@ NotifierThreadProc( } #endif /* TCL_THREADS */ -#endif /* HAVE_COREFOUNDATION */ +#endif /* !HAVE_COREFOUNDATION */ /* * Local Variables: diff --git a/win/tclWinReg.c b/win/tclWinReg.c index c4a89e6..6ac5caf 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -15,6 +15,7 @@ #undef STATIC_BUILD #undef USE_TCL_STUBS #define USE_TCL_STUBS + #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") @@ -23,20 +24,20 @@ #ifndef UNICODE # undef Tcl_WinTCharToUtf -# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) +# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) # undef Tcl_WinUtfToTChar -# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) -#endif +# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) +#endif /* !UNICODE */ /* * Ensure that we can say which registry is being accessed. */ #ifndef KEY_WOW64_64KEY -#define KEY_WOW64_64KEY (0x0100) +# define KEY_WOW64_64KEY (0x0100) #endif #ifndef KEY_WOW64_32KEY -#define KEY_WOW64_32KEY (0x0200) +# define KEY_WOW64_32KEY (0x0200) #endif /* @@ -44,7 +45,7 @@ */ #ifndef MAX_KEY_LENGTH -#define MAX_KEY_LENGTH 256 +# define MAX_KEY_LENGTH 256 #endif /* @@ -57,14 +58,6 @@ #define TCL_STORAGE_CLASS DLLEXPORT /* - * The maximum length of a sub-key name. - */ - -#ifndef MAX_KEY_LENGTH -#define MAX_KEY_LENGTH 256 -#endif - -/* * The following macros convert between different endian ints. */ @@ -817,16 +810,16 @@ GetValue( * we get bogus data. */ - while ((p < end) - && (*((Tcl_UniChar *) p)) != 0) { + while ((p < end) && *((Tcl_UniChar *) p) != 0) { Tcl_UniChar *up; + Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); up = (Tcl_UniChar *) p; - while (*up++ != 0) {} + while (*up++ != 0) {/* empty body */} p = (char *) up; Tcl_DStringFree(&buf); } @@ -1226,8 +1219,8 @@ RecursiveDeleteKey( } break; } else if (result == ERROR_SUCCESS) { - result = RecursiveDeleteKey(hKey, (const TCHAR *) Tcl_DStringValue(&subkey), - mode); + result = RecursiveDeleteKey(hKey, + (const TCHAR *) Tcl_DStringValue(&subkey), mode); } } Tcl_DStringFree(&subkey); @@ -1294,8 +1287,8 @@ SetValue( return TCL_ERROR; } - value = ConvertDWORD((DWORD)type, (DWORD)value); - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + value = ConvertDWORD((DWORD) type, (DWORD) value); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; @@ -1329,7 +1322,7 @@ SetValue( Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), (DWORD) Tcl_DStringLength(&buf)); Tcl_DStringFree(&data); @@ -1338,7 +1331,7 @@ SetValue( Tcl_DString buf; const char *data = Tcl_GetStringFromObj(dataObj, &length); - data = (char *)Tcl_WinUtfToTChar(data, length, &buf); + data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* * Include the null in the length, padding if needed for Unicode. @@ -1347,7 +1340,7 @@ SetValue( Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); length = Tcl_DStringLength(&buf) + 1; - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) data, (DWORD) length); Tcl_DStringFree(&buf); } else { @@ -1358,7 +1351,7 @@ SetValue( */ data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length); - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, data, (DWORD) length); } @@ -1529,14 +1522,15 @@ ConvertDWORD( DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ DWORD value) /* The value to be converted. */ { - DWORD order = 1; + const DWORD order = 1; DWORD localType; /* * Check to see if the low bit is in the first byte. */ - localType = (*((char *) &order) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; + localType = (*((const char *) &order) == 1) + ? REG_DWORD : REG_DWORD_BIG_ENDIAN; return (type != localType) ? (DWORD) SWAPLONG(value) : value; } -- cgit v0.12 From 628fcd07f4174151315dba9fbb726277d83149fe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Aug 2012 09:25:29 +0000 Subject: [Bug #1536227]: Cygwin network pathname supoort --- ChangeLog | 5 ++ generic/tclFileName.c | 241 ++++++++++++++++++++------------------------------ tests/fileName.test | 6 +- 3 files changed, 104 insertions(+), 148 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9423c98..d6499d7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-08 Jan Nijtmans + + * generic/tclfileName.c: [Bug #1536227]: Cygwin network pathname + * tests/fileName.test: support + 2012-08-07 Don Porter * generic/tclIOUtil.c: [Bug 3554250] Overlooked one field of diff --git a/generic/tclFileName.c b/generic/tclFileName.c index a6bb932..07757d9 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -32,8 +32,8 @@ static const char * ExtractWinRoot(const char *path, Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr); static int SkipToChar(char **stringPtr, int match); -static Tcl_Obj* SplitWinPath(const char *path); -static Tcl_Obj* SplitUnixPath(const char *path); +static Tcl_Obj * SplitWinPath(const char *path); +static Tcl_Obj * SplitUnixPath(const char *path); static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr, const char *separators, Tcl_Obj *pathPtr, int flags, char *pattern, Tcl_GlobTypeData *types); @@ -199,7 +199,7 @@ ExtractWinRoot( Tcl_DStringAppend(resultPtr, path, 2); return &path[2]; } else { - char *tail = (char*)&path[3]; + const char *tail = &path[3]; /* * Skip separators. @@ -377,7 +377,7 @@ TclpGetNativePathType( { Tcl_PathType type = TCL_PATH_ABSOLUTE; int pathLen; - char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* @@ -386,7 +386,7 @@ TclpGetNativePathType( */ if (driveNameLengthPtr != NULL) { - char *end = path + 1; + const char *end = path + 1; while ((*end != '\0') && (*end != '/')) { end++; } @@ -395,31 +395,34 @@ TclpGetNativePathType( } else { switch (tclPlatform) { case TCL_PLATFORM_UNIX: { - char *origPath = path; + const char *origPath = path; /* * Paths that begin with / are absolute. */ -#ifdef __QNX__ - /* - * Check for QNX // prefix - */ - if (*path && (pathLen > 3) && (path[0] == '/') - && (path[1] == '/') && isdigit(UCHAR(path[2]))) { - path += 3; - while (isdigit(UCHAR(*path))) { - ++path; - } - } -#endif if (path[0] == '/') { -#ifdef __CYGWIN__ + ++path; +#if defined(__CYGWIN__) || defined(__QNX__) /* - * Check for Cygwin // network path prefix + * Check for "//" network path prefix */ - if (path[1] == '/') { - path++; + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } +#if defined(__CYGWIN__) + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } +#endif } #endif if (driveNameLengthPtr != NULL) { @@ -427,7 +430,7 @@ TclpGetNativePathType( * We need this addition in case the QNX or Cygwin code was used. */ - *driveNameLengthPtr = (1 + path - origPath); + *driveNameLengthPtr = (path - origPath); } } else { type = TCL_PATH_RELATIVE; @@ -546,7 +549,8 @@ Tcl_SplitPath( Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Obj *tmpPtr, *eltPtr; int i, size, len; - char *p, *str; + char *p; + const char *str; /* * Perform the splitting, using objectified, vfs-aware code. @@ -631,40 +635,43 @@ SplitUnixPath( const char *path) /* Pointer to string containing a path. */ { int length; - const char *p, *elementStart; + const char *origPath = path, *elementStart; Tcl_Obj *result = Tcl_NewObj(); /* * Deal with the root directory as a special case. */ -#ifdef __QNX__ - /* - * Check for QNX // prefix - */ - if ((path[0] == '/') && (path[1] == '/') - && isdigit(UCHAR(path[2]))) { /* INTL: digit */ - path += 3; - while (isdigit(UCHAR(*path))) { /* INTL: digit */ - ++path; - } - } -#endif - - p = path; - if (*p == '/') { - Tcl_Obj *rootElt = Tcl_NewStringObj("/", 1); - p++; -#ifdef __CYGWIN__ + if (*path == '/') { + Tcl_Obj *rootElt; + ++path; +#if defined(__CYGWIN__) || defined(__QNX__) /* - * Check for Cygwin // network path prefix + * Check for "//" network path prefix */ - if (*p == '/') { - Tcl_AppendToObj(rootElt, "/", 1); - p++; + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } +#if defined(__CYGWIN__) + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } +#endif } #endif + rootElt = Tcl_NewStringObj(origPath, path - origPath); Tcl_ListObjAppendElement(NULL, result, rootElt); + while (*path == '/') { + ++path; + } } /* @@ -673,14 +680,14 @@ SplitUnixPath( */ for (;;) { - elementStart = p; - while ((*p != '\0') && (*p != '/')) { - p++; + elementStart = path; + while ((*path != '\0') && (*path != '/')) { + path++; } - length = p - elementStart; + length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart[0] == '~') && (elementStart != path)) { + if ((elementStart[0] == '~') && (elementStart != origPath)) { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { @@ -688,7 +695,7 @@ SplitUnixPath( } Tcl_ListObjAppendElement(NULL, result, nextElt); } - if (*p++ == '\0') { + if (*path++ == '\0') { break; } } @@ -843,8 +850,9 @@ TclpNativeJoinPath( const char *joining) { int length, needsSep; + char *dest; const char *p; - char *dest, *start; + const char *start; start = Tcl_GetStringFromObj(prefix, &length); @@ -968,7 +976,7 @@ Tcl_JoinPath( int i, len; Tcl_Obj *listObj = Tcl_NewObj(); Tcl_Obj *resultObj; - char *resultStr; + const char *resultStr; /* * Build the list of paths. @@ -1338,8 +1346,8 @@ Tcl_GlobObjCmd( if (dir == PATH_GENERAL) { int pathlength; - char *last; - char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); + const char *last; + const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path @@ -1440,7 +1448,7 @@ Tcl_GlobObjCmd( while (--length >= 0) { int len; - char *str; + const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); str = Tcl_GetStringFromObj(look, &len); @@ -1496,10 +1504,10 @@ Tcl_GlobObjCmd( Tcl_IncrRefCount(look); } else { - Tcl_Obj* item; + Tcl_Obj *item; - if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) && - (len == 3)) { + if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) + && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); @@ -1831,7 +1839,7 @@ TclGlob( if (tail[0] == '/') { tail++; } else { - tail+=2; + tail += 2; } Tcl_IncrRefCount(pathPrefix); break; @@ -1902,27 +1910,29 @@ TclGlob( if (*tail == '\0' && pathPrefix != NULL) { /* - * An empty pattern. This means 'pathPrefix' is actually - * a full path of a file/directory we want to simply check - * for existence and type. + * An empty pattern. This means 'pathPrefix' is actually a full path + * of a file/directory we want to simply check for existence and type. */ + if (types == NULL) { /* - * We just want to check for existence. In this case we - * make it easy on Tcl_FSMatchInDirectory and its - * sub-implementations by not bothering them (even though - * they should support this situation) and we just use the - * simple existence check with Tcl_FSAccess. + * We just want to check for existence. In this case we make it + * easy on Tcl_FSMatchInDirectory and its sub-implementations by + * not bothering them (even though they should support this + * situation) and we just use the simple existence check with + * Tcl_FSAccess. */ + if (Tcl_FSAccess(pathPrefix, F_OK) == 0) { Tcl_ListObjAppendElement(interp, filenamesObj, pathPrefix); } result = TCL_OK; } else { /* - * We want to check for the correct type. Tcl_FSMatchInDirectory + * We want to check for the correct type. Tcl_FSMatchInDirectory * is documented to do this for us, if we give it a NULL pattern. */ + result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix, NULL, types); } @@ -1987,20 +1997,20 @@ TclGlob( Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; - char *oldStr = Tcl_GetStringFromObj(objv[i], &len); - Tcl_Obj* elems[1]; + const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); + Tcl_Obj *elem; if (len == prefixLen) { if ((pattern[0] == '\0') || (strchr(separators, pattern[0]) == NULL)) { - TclNewLiteralStringObj(elems[0], "."); + TclNewLiteralStringObj(elem, "."); } else { - TclNewLiteralStringObj(elems[0], "/"); + TclNewLiteralStringObj(elem, "/"); } } else { - elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen); + elem = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen); } - Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems); + Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, &elem); } } @@ -2115,7 +2125,7 @@ DoGlob( * resulting filenames. Caller allocates and * deallocates; DoGlob must not touch the * refCount of this object. */ - const char *separators, /* String containing separator characters that + const char *separators, /* String containing separator characters that * should be used to identify globbing * boundaries. */ Tcl_Obj *pathPtr, /* Completely expanded prefix. */ @@ -2159,67 +2169,6 @@ DoGlob( } /* - * This block of code is not exercised by the Tcl test suite as of Tcl - * 8.5a0. Simplifications to the calling paths suggest it may not be - * necessary any more, since path separators are handled elsewhere. It is - * left in place in case new bugs are reported. - */ - -#if 0 /* PROBABLY_OBSOLETE */ - /* - * Deal with path separators. - */ - - if (pathPtr == NULL) { - /* - * Length used to be the length of the prefix, and lastChar the - * lastChar of the prefix. But, none of this is used any more. - */ - - int length = 0; - char lastChar = 0; - - switch (tclPlatform) { - case TCL_PLATFORM_WINDOWS: - /* - * If this is a drive relative path, add the colon and the - * trailing slash if needed. Otherwise add the slash if this is - * the first absolute element, or a later relative element. Add an - * extra slash if this is a UNC path. - */ - - if (*name == ':') { - Tcl_DStringAppend(&append, ":", 1); - if (count > 1) { - Tcl_DStringAppend(&append, "/", 1); - } - } else if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - if ((length == 0) && (count > 1)) { - Tcl_DStringAppend(&append, "/", 1); - } - } - - break; - case TCL_PLATFORM_UNIX: - /* - * Add a separator if this is the first absolute element, or a - * later relative element. - */ - - if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - } - break; - } - } -#endif /* PROBABLY_OBSOLETE */ - - /* * Look for the first matching pair of braces or the first directory * separator that is not inside a pair of braces. */ @@ -2273,8 +2222,8 @@ DoGlob( if (openBrace != NULL) { char *element; - Tcl_DString newName; + Tcl_DStringInit(&newName); /* @@ -2323,12 +2272,13 @@ DoGlob( */ if (*p != '\0') { + char savedChar = *p; + /* * Note that we are modifying the string in place. This won't work if * the string is a static. */ - char savedChar = *p; *p = '\0'; firstSpecialChar = strpbrk(pattern, "*[]?\\"); *p = savedChar; @@ -2347,7 +2297,7 @@ DoGlob( TCL_GLOB_TYPE_DIR, 0, NULL, NULL }; char save = *p; - Tcl_Obj* subdirsPtr; + Tcl_Obj *subdirsPtr; if (*p == '\0') { return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr, @@ -2393,6 +2343,7 @@ DoGlob( const char *bytes; int numBytes; Tcl_Obj *fixme, *newObj; + Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); bytes = Tcl_GetStringFromObj(fixme, &numBytes); newObj = Tcl_NewStringObj(bytes+2, numBytes-2); @@ -2413,6 +2364,9 @@ DoGlob( */ if (*p == '\0') { + int length; + Tcl_DString append; + /* * This is the code path reached by a command like 'glob foo'. * @@ -2425,9 +2379,6 @@ DoGlob( * approach). */ - int length; - Tcl_DString append; - Tcl_DStringInit(&append); Tcl_DStringAppend(&append, pattern, p-pattern); diff --git a/tests/fileName.test b/tests/fileName.test index a91f4b3..68c5592 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -189,7 +189,7 @@ test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} { test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split //foo -} "[file split //] foo" +} "/ foo" test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo//bar @@ -429,11 +429,11 @@ test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join //a b -} "[file split //]a/b" +} "/a/b" test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /// a b -} "[file split //]a/b" +} "/a/b" test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { -- cgit v0.12 From 33cc01511db658ebb4f67017d451fb9fbf4edf23 Mon Sep 17 00:00:00 2001 From: twylite Date: Wed, 8 Aug 2012 15:28:09 +0000 Subject: Back-out 'foreacha' implementation but leave code cleanup of 'mapeach' and 'dict map'. --- generic/tclBasic.c | 1 - generic/tclCmdAH.c | 58 ++++++++++----------------------------------------- generic/tclCompCmds.c | 23 ++------------------ generic/tclCompile.h | 1 - generic/tclExecute.c | 17 +++------------ generic/tclInt.h | 10 --------- 6 files changed, 16 insertions(+), 94 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fe8fa5a..a35da29 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -219,7 +219,6 @@ static const CmdInfo builtInCmds[] = { {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, - {"foreacha", Tcl_ForeachaObjCmd, TclCompileForeachaCmd, TclNRForeachaCmd, 1}, {"format", Tcl_FormatObjCmd, NULL, NULL, 1}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 333946a..a10646c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -45,7 +45,7 @@ static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static inline int ForeachAssignments(Tcl_Interp *interp, - struct ForeachState *statePtr, int collect); + struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, struct ForeachState *statePtr); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -2619,26 +2619,6 @@ TclNRMapeachCmd( } int -Tcl_ForeachaObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRForeachaCmd, dummy, objc, objv); -} - -int -TclNRForeachaCmd( - ClientData dummy, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_ACCUM); -} - -int TclNREachloopCmd( ClientData dummy, Tcl_Interp *interp, @@ -2720,13 +2700,9 @@ TclNREachloopCmd( TclListObjGetElements(NULL, statePtr->aCopyList[i], &statePtr->argcList[i], &statePtr->argvList[i]); - j = (i == 0) && (collect == TCL_EACH_ACCUM); /* Accumulator present? */ - /* If accumulator is only var in list, then we iterate j=1 times */ - if (statePtr->varcList[i] > j) { - /* We need listLen/numVars round up = ((listLen+numVars-1)/numVars) - * When accum is present we need (listLen-1)/(numVars-1) round up */ - j = (statePtr->argcList[i] - j + statePtr->varcList[i] - j - 1) - / (statePtr->varcList[i] - j); + j = statePtr->argcList[i] / statePtr->varcList[i]; + if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { + j++; } if (j > statePtr->maxj) { statePtr->maxj = j; @@ -2739,7 +2715,7 @@ TclNREachloopCmd( */ if (statePtr->maxj > 0) { - result = ForeachAssignments(interp, statePtr, collect); + result = ForeachAssignments(interp, statePtr); if (result == TCL_ERROR) { goto done; } @@ -2803,7 +2779,7 @@ ForeachLoopStep( */ if (statePtr->maxj > ++statePtr->j) { - result = ForeachAssignments(interp, statePtr, collect); + result = ForeachAssignments(interp, statePtr); if (result == TCL_ERROR) { goto done; } @@ -2816,18 +2792,9 @@ ForeachLoopStep( /* * We're done. Tidy up our work space and finish off. */ -finish: - if (collect == TCL_EACH_ACCUM) { - Tcl_Obj* valueObj = Tcl_ObjGetVar2(interp, statePtr->varvList[0][0], - NULL, TCL_LEAVE_ERR_MSG); - if (valueObj == NULL) { - goto done; - } - Tcl_SetObjResult(interp, valueObj); - } else { - Tcl_SetObjResult(interp, statePtr->resultList); - statePtr->resultList = NULL; /* Don't clean it up */ - } + finish: + Tcl_SetObjResult(interp, statePtr->resultList); + statePtr->resultList = NULL; /* Don't clean it up */ done: ForeachCleanup(interp, statePtr); return result; @@ -2840,16 +2807,13 @@ finish: static inline int ForeachAssignments( Tcl_Interp *interp, - struct ForeachState *statePtr, - int collect) /* Select collecting or accumulating mode (TCL_EACH_*) */ + struct ForeachState *statePtr) { int i, v, k; Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; inumLists ; i++) { - /* Don't modify the accumulator except on the first iteration */ - v = ((i == 0) && (collect == TCL_EACH_ACCUM) && (statePtr->index[i] > 0)); - for (; vvarcList[i] ; v++) { + for (v=0 ; vvarcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 07a5eea..395a0f8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1911,9 +1911,9 @@ TclCompileForCmd( /* *---------------------------------------------------------------------- * - * TclCompileForeachCmd, TclCompileForeachaCmd -- + * TclCompileForeachCmd -- * - * Procedure called to compile the "foreach" and "foreacha" commands. + * Procedure called to compile the "foreach" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer @@ -1937,18 +1937,6 @@ TclCompileForeachCmd( { return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 0); } - -int -TclCompileForeachaCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 2); -} /* *---------------------------------------------------------------------- @@ -2136,7 +2124,6 @@ TclCompileEachloopCmd( infoPtr->numLists = numLists; infoPtr->firstValueTemp = firstValueTemp; infoPtr->loopCtTemp = loopCtTemp; - infoPtr->collect = collect; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; @@ -2150,9 +2137,6 @@ TclCompileEachloopCmd( varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, nameChars, /*create*/ 1, envPtr); - if ((collect == TCL_EACH_ACCUM) && ((loopIndex + j) == 0)) { - collectTemp = varListPtr->varIndexes[j]; - } } infoPtr->varLists[loopIndex] = varListPtr; } @@ -2344,7 +2328,6 @@ DupForeachInfo( dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; - dupPtr->collect = srcPtr->collect; for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; @@ -2435,8 +2418,6 @@ PrintForeachInfo( } Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", (unsigned) infoPtr->loopCtTemp); - Tcl_AppendPrintfToObj(appendObj, "], collect=%%v%u", - (unsigned) infoPtr->collect); for (i=0 ; inumLists ; i++) { if (i) { Tcl_AppendToObj(appendObj, ",", -1); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 7a41bb1..ba78c36 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -807,7 +807,6 @@ typedef struct ForeachInfo { * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ - int collect; /* Selected collecting or accumulating mode. */ ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 952eb32..e402634 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5492,15 +5492,7 @@ TEBCresume( opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); goto gotError; } - - /* If the accumulator is the only variable then this list gets - * just one iteration. Otherwise we must keep going until the - * list is exhausted by non-accumulator loop vars */ - j = ((i == 0) && (iterNum > 0) - && (infoPtr->collect == TCL_EACH_ACCUM)); - /* j is 1 if the accumulator is present but does not consume - * an element, or 0 otherwise (consuming or not-present). */ - if ((numVars > j) && (listLen > (iterNum * (numVars - j) + j))) { + if (listLen > iterNum * numVars) { continueLoop = 1; } listTmpIndex++; @@ -5525,11 +5517,8 @@ TEBCresume( listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); TclListObjGetElements(interp, listPtr, &listLen, &elements); - /* Don't modify the accumulator except on the first iteration */ - j = ((i == 0) && (iterNum > 0) - && (infoPtr->collect == TCL_EACH_ACCUM)); - valIndex = (iterNum * (numVars - j) + j); - for (; j < numVars; j++) { + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { if (valIndex >= listLen) { TclNewObj(valuePtr); } else { diff --git a/generic/tclInt.h b/generic/tclInt.h index 6600dd9..4fc265f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2773,7 +2773,6 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachaCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRMapeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; @@ -2865,9 +2864,6 @@ struct Tcl_LoadHandle_ { #define TCL_EACH_COLLECT 1 /* Collect iteration result like [mapeach] */ -#define TCL_EACH_ACCUM 2 - /* First loop var is accumulator like [foreacha] */ - /* *---------------------------------------------------------------- @@ -3314,9 +3310,6 @@ MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForeachaObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3549,9 +3542,6 @@ MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileForeachaCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 167434d6d48afa4ca516659a7b123c761dd3151b Mon Sep 17 00:00:00 2001 From: twylite Date: Wed, 8 Aug 2012 15:34:13 +0000 Subject: Rename 'mapeach' to 'lmap' per preferred alternative in TIP #405. --- generic/tclBasic.c | 2 +- generic/tclCmdAH.c | 6 +- generic/tclCompCmds.c | 10 +- generic/tclInt.h | 16 +- tests/lmap.test | 493 ++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 510 insertions(+), 17 deletions(-) create mode 100644 tests/lmap.test diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a35da29..36e777a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -230,6 +230,7 @@ static const CmdInfo builtInCmds[] = { {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, + {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1}, @@ -237,7 +238,6 @@ static const CmdInfo builtInCmds[] = { {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, - {"mapeach", Tcl_MapeachObjCmd, TclCompileMapeachCmd, TclNRMapeachCmd, 1}, {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index a10646c..9ebdf21 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2599,17 +2599,17 @@ TclNRForeachCmd( } int -Tcl_MapeachObjCmd( +Tcl_LmapObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRMapeachCmd, dummy, objc, objv); + return Tcl_NRCallObjProc(interp, TclNRLmapCmd, dummy, objc, objv); } int -TclNRMapeachCmd( +TclNRLmapCmd( ClientData dummy, Tcl_Interp *interp, int objc, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 395a0f8..4d015ec 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1943,7 +1943,7 @@ TclCompileForeachCmd( * * TclCompileEachloopCmd -- * - * Procedure called to compile the "foreach" and "mapeach" commands. + * Procedure called to compile the "foreach" and "lmap" commands. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer @@ -3832,23 +3832,23 @@ TclCompileLsetCmd( /* *---------------------------------------------------------------------- * - * TclCompileMapeachCmd -- + * TclCompileLmapCmd -- * - * Procedure called to compile the "mapeach" command. + * Procedure called to compile the "lmap" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "mapeach" command at + * Instructions are added to envPtr to execute the "lmap" command at * runtime. * *---------------------------------------------------------------------- */ int -TclCompileMapeachCmd( +TclCompileLmapCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 4fc265f..f1a6fce 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2774,7 +2774,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRMapeachCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; @@ -2862,7 +2862,7 @@ struct Tcl_LoadHandle_ { /* Discard iteration result like [foreach] */ #define TCL_EACH_COLLECT 1 - /* Collect iteration result like [mapeach] */ + /* Collect iteration result like [lmap] */ /* @@ -3353,6 +3353,9 @@ MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3377,9 +3380,6 @@ MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_MapeachObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy, Tcl_Interp *interp, int objc, @@ -3569,6 +3569,9 @@ MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLmapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3578,9 +3581,6 @@ MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileMapeachCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/tests/lmap.test b/tests/lmap.test new file mode 100644 index 0000000..dc5053f --- /dev/null +++ b/tests/lmap.test @@ -0,0 +1,493 @@ +# Commands covered: lmap, continue, break +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 2011 Trevor Davel +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +catch {unset a} +catch {unset i} +catch {unset x} + +# ----- Non-compiled operation ------------------------------------------------- + + +# Basic "lmap" operation (non-compiled) + +test lmap-1.1 {basic lmap tests} { + set a {} + lmap i {a b c d} { + set a [concat $a $i] + } +} {a {a b} {a b c} {a b c d}} +test lmap-1.2 {basic lmap tests} { + lmap i {a b {{c d} e} {123 {{x}}}} { + set i + } +} {a b {{c d} e} {123 {{x}}}} +test lmap-1.2a {basic lmap tests} { + lmap i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } +} {a b {{c d} e} {123 {{x}}}} +test lmap-1.3 {basic lmap tests} {catch {lmap} msg} 1 +test lmap-1.4 {basic lmap tests} { + catch {lmap} msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.5 {basic lmap tests} {catch {lmap i} msg} 1 +test lmap-1.6 {basic lmap tests} { + catch {lmap i} msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.7 {basic lmap tests} {catch {lmap i j} msg} 1 +test lmap-1.8 {basic lmap tests} { + catch {lmap i j} msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.9 {basic lmap tests} {catch {lmap i j k l} msg} 1 +test lmap-1.10 {basic lmap tests} { + catch {lmap i j k l} msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.11 {basic lmap tests} { + lmap i {} { + set i + } +} {} +test lmap-1.12 {basic lmap tests} { + lmap i {} { + return -level 0 x + } +} {} +test lmap-1.13 {lmap errors} { + list [catch {lmap {{a}{b}} {1 2 3} {}} msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test lmap-1.14 {lmap errors} { + list [catch {lmap a {{1 2}3} {}} msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test lmap-1.15 {lmap errors} { + catch {unset a} + set a(0) 44 + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo +} {1 {can't set "a": variable is array} {can't set "a": variable is array + (setting foreach loop variable "a") + invoked from within +"lmap a {1 2 3} {}"}} +test lmap-1.16 {lmap errors} { + list [catch {lmap {} {} {}} msg] $msg +} {1 {foreach varlist is empty}} +catch {unset a} + + +# Parallel "lmap" operation (non-compiled) + +test lmap-2.1 {parallel lmap tests} { + lmap {a b} {1 2 3 4} { + list $b $a + } +} {{2 1} {4 3}} +test lmap-2.2 {parallel lmap tests} { + lmap {a b} {1 2 3 4 5} { + list $b $a + } +} {{2 1} {4 3} {{} 5}} +test lmap-2.3 {parallel lmap tests} { + lmap a {1 2 3} b {4 5 6} { + list $b $a + } +} {{4 1} {5 2} {6 3}} +test lmap-2.4 {parallel lmap tests} { + lmap a {1 2 3} b {4 5 6 7 8} { + list $b $a + } +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test lmap-2.5 {parallel lmap tests} { + lmap {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test lmap-2.6 {parallel lmap tests} { + lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } +} {11111 22222 33333} +test lmap-2.7 {parallel lmap tests} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } +} {{1111 2} 222 33 4} +test lmap-2.8 {parallel lmap tests} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test lmap-2.9 {lmap only sets vars if repeating loop} { + namespace eval ::lmap_test { + set rgb {65535 0 0} + lmap {r g b} [set rgb] {} + set ::x "r=$r, g=$g, b=$b" + } + namespace delete ::lmap_test + set x +} {r=65535, g=0, b=0} +test lmap-2.10 {lmap only supports local scalar variables} { + catch { unset a } + lmap {a(3)} {1 2 3 4} {set {a(3)}} +} {1 2 3 4} +catch { unset a } + + +# "lmap" with "continue" and "break" (non-compiled) + +test lmap-3.1 {continue tests} { + lmap i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } +} {a c d} +test lmap-3.2 {continue tests} { + set x 0 + list [lmap i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x +} {b 4} +test lmap-3.3 {break tests} { + set x 0 + list [lmap i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x +} {{a b} 3} +# Check for bug similar to #406709 +test lmap-3.4 {break tests} { + set a 1 + lmap b b {list [concat a; break]; incr a} + incr a +} {2} + + +# ----- Compiled operation ------------------------------------------------------ + +# Basic "lmap" operation (compiled) + +test lmap-4.1 {basic lmap tests} { + apply {{} { + set a {} + lmap i {a b c d} { + set a [concat $a $i] + } + }} +} {a {a b} {a b c} {a b c d}} +test lmap-4.2 {basic lmap tests} { + apply {{} { + lmap i {a b {{c d} e} {123 {{x}}}} { + set i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test lmap-4.2a {basic lmap tests} { + apply {{} { + lmap i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test lmap-4.3 {basic lmap tests} {catch { apply {{} { lmap }} } msg} 1 +test lmap-4.4 {basic lmap tests} { + catch { apply {{} { lmap }} } msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.5 {basic lmap tests} {catch { apply {{} { lmap i }} } msg} 1 +test lmap-4.6 {basic lmap tests} { + catch { apply {{} { lmap i }} } msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.7 {basic lmap tests} {catch { apply {{} { lmap i j }} } msg} 1 +test lmap-4.8 {basic lmap tests} { + catch { apply {{} { lmap i j }} } msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.9 {basic lmap tests} {catch { apply {{} { lmap i j k l }} } msg} 1 +test lmap-4.10 {basic lmap tests} { + catch { apply {{} { lmap i j k l }} } msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.11 {basic lmap tests} { + apply {{} { lmap i {} { set i } }} +} {} +test lmap-4.12 {basic lmap tests} { + apply {{} { lmap i {} { return -level 0 x } }} +} {} +test lmap-4.13 {lmap errors} { + list [catch { apply {{} { lmap {{a}{b}} {1 2 3} {} }} } msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test lmap-4.14 {lmap errors} { + list [catch { apply {{} { lmap a {{1 2}3} {} }} } msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test lmap-4.15 {lmap errors} { + apply {{} { + set a(0) 44 + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo + }} +} {1 {can't set "a": variable is array} {can't set "a": variable is array + while executing +"lmap a {1 2 3} {}"}} +test lmap-4.16 {lmap errors} { + list [catch { apply {{} { lmap {} {} {} }} } msg] $msg +} {1 {foreach varlist is empty}} +catch {unset a} + + +# Parallel "lmap" operation (compiled) + +test lmap-5.1 {parallel lmap tests} { + apply {{} { + lmap {a b} {1 2 3 4} { + list $b $a + } + }} +} {{2 1} {4 3}} +test lmap-5.2 {parallel lmap tests} { + apply {{} { + lmap {a b} {1 2 3 4 5} { + list $b $a + } + }} +} {{2 1} {4 3} {{} 5}} +test lmap-5.3 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {4 5 6} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3}} +test lmap-5.4 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {4 5 6 7 8} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test lmap-5.5 {parallel lmap tests} { + apply {{} { + lmap {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } + }} +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test lmap-5.6 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } + }} +} {11111 22222 33333} +test lmap-5.7 {parallel lmap tests} { + apply {{} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } + }} +} {{1111 2} 222 33 4} +test lmap-5.8 {parallel lmap tests} { + apply {{} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } + }} +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test lmap-5.9 {lmap only sets vars if repeating loop} { + apply {{} { + set rgb {65535 0 0} + lmap {r g b} [set rgb] {} + return "r=$r, g=$g, b=$b" + }} +} {r=65535, g=0, b=0} +test lmap-5.10 {lmap only supports local scalar variables} { + apply {{} { + lmap {a(3)} {1 2 3 4} {set {a(3)}} + }} +} {1 2 3 4} + + +# "lmap" with "continue" and "break" (compiled) + +test lmap-6.1 {continue tests} { + apply {{} { + lmap i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } + }} +} {a c d} +test lmap-6.2 {continue tests} { + apply {{} { + list [lmap i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x + }} +} {b 4} +test lmap-6.3 {break tests} { + apply {{} { + list [lmap i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x + }} +} {{a b} 3} +# Check for bug similar to #406709 +test lmap-6.4 {break tests} { + apply {{} { + set a 1 + lmap b b {list [concat a; break]; incr a} + incr a + }} +} {2} + + + +# ----- Special cases and bugs ------------------------------------------------- + + +test lmap-7.1 {compiled lmap backward jump works correctly} { + catch {unset x} + array set x {0 zero 1 one 2 two 3 three} + lsort [apply {{arrayName} { + upvar 1 $arrayName a + lmap member [array names a] { + list $member [set a($member)] + } + }} x] +} [lsort {{0 zero} {1 one} {2 two} {3 three}}] + +test lmap-7.2 {noncompiled lmap and shared variable or value list objects that are converted to another type} { + catch {unset x} + lmap {12.0} {a b c} { + set x 12.0 + set x [expr $x + 1] + } +} {13.0 13.0 13.0} + +# Test for incorrect "double evaluation" semantics +test lmap-7.3 {delayed substitution of body} { + apply {{} { + set a 0 + lmap a [list 1 2 3] " + set x $a + " + set x + }} +} {0} + +# Related to "foreach" test for [Bug 1189274]; crash on failure +test lmap-7.4 {empty list handling} { + proc crash {} { + rename crash {} + set a "x y z" + set b "" + lmap aa $a bb $b { set x "aa = $aa bb = $bb" } + } + crash +} {{aa = x bb = } {aa = y bb = } {aa = z bb = }} + +# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled version +test lmap-7.5 {compiled empty var list} { + proc foo {} { + lmap {} x { + error "reached body" + } + } + list [catch { foo } msg] $msg +} {1 {foreach varlist is empty}} + +test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup { + proc demo {} { + set vals {1 2 3 4} + trace add variable x write {string length $vals ;# } + lmap {x y} $vals {format $y} + } +} -body { + demo +} -cleanup { + rename demo {} +} -result {2 4} + +# Huge lists must not overflow the bytecode interpreter (development bug) +test lmap-7.7 {huge list non-compiled} { + set x [lmap a [lrepeat 1000000 x] { set b y$a }] + list $b [llength $x] [string length $x] +} {yx 1000000 2999999} + +test lmap-7.8 {huge list compiled} { + set x [apply {{times} { lmap a [lrepeat $times x] { set b y$a }}} 1000000] + list $b [llength $x] [string length $x] +} {yx 1000000 2999999} + +test lmap-7.9 {error then dereference loop var (dev bug)} { + catch { lmap a 0 b {1 2 3} { error x } } + set a +} 0 +test lmap-7.9a {error then dereference loop var (dev bug)} { + catch { lmap a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 + +# ----- Coroutines ------------------------------------------------------------- + +test lmap-8.1 {lmap non-compiled with coroutines} { + coroutine coro apply {{} { + set values [yield [info coroutine]] + eval lmap i [list $values] {{ yield $i }} + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} {{1 2 3 4 5 6} {}} + +test lmap-8.2 {lmap compiled with coroutines} { + coroutine coro apply {{} { + set values [yield [info coroutine]] + lmap i $values { yield $i } + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} {{1 2 3 4 5 6} {}} + + +# cleanup +catch {unset a} +catch {unset x} +catch {rename foo {}} +::tcltest::cleanupTests +return -- cgit v0.12 From c7b9c3391a7f06815fd0c3e83f795e3dea514aaf Mon Sep 17 00:00:00 2001 From: twylite Date: Wed, 8 Aug 2012 16:00:10 +0000 Subject: Man page updates for command rename from 'mapeach' to 'lmap'. --- doc/lmap.n | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) create mode 100644 doc/lmap.n diff --git a/doc/lmap.n b/doc/lmap.n new file mode 100644 index 0000000..7deb7f9 --- /dev/null +++ b/doc/lmap.n @@ -0,0 +1,91 @@ +'\" +'\" Copyright (c) 2012 Trevor Davel +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.so man.macros +.TH lmap n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lmap \- Iterate over all elements in one or more lists and collect results +.SH SYNOPSIS +\fBlmap \fIvarname list body\fR +.br +\fBlmap \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR +.BE + +.SH DESCRIPTION +.PP +The \fBlmap\fR command implements a loop where the loop +variable(s) take on values from one or more lists, and the loop returns a list +of results collected from each iteration. +.PP +In the simplest case there is one loop variable, \fIvarname\fR, +and one list, \fIlist\fR, that is a list of values to assign to \fIvarname\fR. +The \fIbody\fR argument is a Tcl script. +For each element of \fIlist\fR (in order +from first to last), \fBlmap\fR assigns the contents of the +element to \fIvarname\fR as if the \fBlindex\fR command had been used +to extract the element, then calls the Tcl interpreter to execute +\fIbody\fR. If execution of the body completes normally then the result of the +body is appended to an accumulator list. \fBlmap\fR returns the accumulator +list. + +.PP +In the general case there can be more than one value list +(e.g., \fIlist1\fR and \fIlist2\fR), +and each value list can be associated with a list of loop variables +(e.g., \fIvarlist1\fR and \fIvarlist2\fR). +During each iteration of the loop +the variables of each \fIvarlist\fR are assigned +consecutive values from the corresponding \fIlist\fR. +Values in each \fIlist\fR are used in order from first to last, +and each value is used exactly once. +The total number of loop iterations is large enough to use +up all the values from all the value lists. +If a value list does not contain enough +elements for each of its loop variables in each iteration, +empty values are used for the missing elements. +.PP +The \fBbreak\fR and \fBcontinue\fR statements may be +invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR +and \fBforeach\fR commands. In these cases the body does not complete normally +and the result is not appended to the accumulator list. +.SH EXAMPLES +.PP +Zip lists together: +.PP +.CS +'\" Maintainers: notice the tab hacking below! +.ta 3i +set list1 {a b c d} +set list2 {1 2 3 4} +set zipped [\fBlmap\fR a $list1 b $list2 {list $a $b}] +# The value of zipped is "{a 1} {b 2} {c 3} {d 4}" +.CE +.PP +Filter a list: +.PP +.CS +set values {1 2 3 4 5 6 7 8} +proc isGood {n} { expr { ($n % 2) == 0 } } +set goodOnes [\fBlmap\fR x $values {expr {[isGood $x] ? $x : [continue]}}] +# The value of goodOnes is "2 4 6 8" +.CE +.PP +Take a prefix from a list: +.PP +.CS +set values {8 7 6 5 4 3 2 1} +proc isGood {n} { expr { $n > 3 } } +set prefix [\fBlmap\fR x $values {expr {[isGood $x] ? $x : [break]}}] +# The value of prefix is "8 7 6 5 4" +.CE + +.SH "SEE ALSO" +for(n), while(n), break(n), continue(n), foreach(n) + +.SH KEYWORDS +foreach, iteration, list, loop, map -- cgit v0.12 From f8d1f021800b7e4ee1affecce67cdcc6f2dd1a54 Mon Sep 17 00:00:00 2001 From: stwo Date: Wed, 8 Aug 2012 23:07:27 +0000 Subject: Change one '#ifdef' to '#if defined()' for improved consistency within the file. --- ChangeLog | 5 +++++ unix/tclUnixCompat.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index cbbfea1..95a67b9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2010-08-08 Stuart Cassoff + + * unix/tclUnixCompat.c: Change one '#ifdef' to '#if defined()' for + improved consistency within the file. + 2012-08-08 Jan Nijtmans * generic/tclfileName.c: [Bug #1536227]: Cygwin network pathname diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 3818121..359e253 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -364,7 +364,7 @@ TclpGetGrNam( #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); -#ifdef HAVE_GETGRNAM_R_5 +#if defined(HAVE_GETGRNAM_R_5) struct group *grPtr = NULL; /* -- cgit v0.12 From 426550b55b6255c0c5aef226ea721fe9bf94b472 Mon Sep 17 00:00:00 2001 From: max Date: Thu, 9 Aug 2012 14:26:04 +0000 Subject: Fix http-3.29 for machines without IPv6 support. --- ChangeLog | 4 ++++ tests/http.test | 16 ++++++++++++---- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 95a67b9..3d6e6d7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2012-08-09 Reinhard Max + + * tests/http.test: Fix http-3.29 for machines without IPv6 support. + 2010-08-08 Stuart Cassoff * unix/tclUnixCompat.c: Change one '#ifdef' to '#if defined()' for diff --git a/tests/http.test b/tests/http.test index fe44b47..bde5795 100644 --- a/tests/http.test +++ b/tests/http.test @@ -392,11 +392,19 @@ Content-Type {text/plain;charset=utf-8} Accept-Encoding .* Content-Length 5} test http-3.29 "http::geturl $ipv6url" -body { - set token [http::geturl $ipv6url -validate 1] - http::code $token + # We only want to see if the URL gets parsed correctly. This is + # the case if http::geturl succeeds or returns a socket related + # error. If the parsing is wrong, we'll get a parse error. + # It'd be better to separate the URL parser from http::geturl, so + # that it can be tested without also trying to make a connection. + set error [catch {http::geturl $ipv6url -validate 1} token] + if {$error && [string match "couldn't open socket: *" $token]} { + set error 0 + } + set error } -cleanup { - http::cleanup $token -} -result "HTTP/1.0 200 OK" + catch { http::cleanup $token } +} -result 0 test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] -- cgit v0.12 From 063747525bde41ea8de3c5c01170148084fd801d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Aug 2012 04:42:33 +0000 Subject: minor fix --- doc/dde.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/dde.n b/doc/dde.n index e4b51b7..0acceac 100644 --- a/doc/dde.n +++ b/doc/dde.n @@ -88,7 +88,7 @@ string is sent. Combining \fB-binary\fR with the result of \fBencoding convertto\fR may be used to send data in arbitrary encodings. .VE 8.6 .TP -\fBdde poke ?\fB\-binary\fR? \fIservice topic item data\fR +\fBdde poke\fR ?\fB\-binary\fR? \fIservice topic item data\fR . \fBdde poke\fR passes the \fIdata\fR to the server indicated by \fIservice\fR using the \fItopic\fR and \fIitem\fR specified. Typically, -- cgit v0.12 From cbe9080dcf08715a284c858235ef5c3350b4a376 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 13 Aug 2012 10:05:16 +0000 Subject: tinkering with the documentation --- doc/zlib.n | 43 +++++++++++++++++++++++++++++++------------ 1 file changed, 31 insertions(+), 12 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index 0233ba8..2610527 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -170,6 +170,13 @@ the .QW "\fIoptions ...\fR" to the \fBzlib push\fR command: .TP +\fB\-dictionary\fI binData\fR +.VS "TIP 400" +Sets the compression dictionary to use when working with compressing or +decompressing the data to be \fIbinData\fR. Not valid for transformations that +work with gzip-format data. +.VE +.TP \fB\-header\fI dictionary\fR . Passes a description of the gzip header to create, in the same format that @@ -198,6 +205,15 @@ the compression engine has seen so far. It is valid for both compressing and decompressing transforms, but not for the raw inflate and deflate formats. The compression algorithm depends on what format is being produced or consumed. .TP +\fB\-dictionary\fI binData\fR +.VS "TIP 400" +This read-write options gets or sets the compression dictionary to use when +working with compressing or decompressing the data to be \fIbinData\fR. It is +not valid for transformations that work with gzip-format data, and should not +normally be set on compressing transformations other than at the point where +the transformation is stacked. +.VE +.TP \fB\-flush\fI type\fR . This write-only operation flushes the current state of the compressor to the @@ -223,12 +239,12 @@ is non-blocking. .RE .SS "STREAMING SUBCOMMAND" .TP -\fBzlib stream\fI mode\fR ?\fIlevel\fR? +\fBzlib stream\fI mode\fR ?\fIoptions\fR? . Creates a streaming compression or decompression command based on the \fImode\fR, and return the name of the command. For a description of how that command works, see \fBSTREAMING INSTANCE COMMAND\fR below. The following modes -are supported: +and \fIoptions\fR are supported: .RS .TP \fBzlib stream compress\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? @@ -236,7 +252,7 @@ are supported: The stream will be a compressing stream that produces zlib-format output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, -.VS +.VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). .VE .TP @@ -244,7 +260,7 @@ and the compression dictionary \fIbindata\fR (if specified). . The stream will be a decompressing stream that takes zlib-format input and produces uncompressed output. -.VS +.VS "TIP 400" If \fIbindata\fR is supplied, it is a compression dictionary to use if required. .VE @@ -254,13 +270,13 @@ required. The stream will be a compressing stream that produces raw output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, -.VS +.VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). Note that the raw compressed data includes no metadata about what compression dictionary was used, if any; that is a feature of the zlib-format data. .VE .TP -\fBzlib stream gunzip\fR ?\fIlevel\fR? +\fBzlib stream gunzip\fR . The stream will be a decompressing stream that takes gzip-format input and produces uncompressed output. @@ -275,9 +291,12 @@ for keys see \fBzlib gzip\fR). \fBzlib stream inflate\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes raw compressed input and -produces uncompressed output. If \fIbindata\fR is supplied, it is a -compression dictionary to use. Note that there are no checks in place -to determine whether the compression dictionary is correct. +produces uncompressed output. +.VS "TIP 400" +If \fIbindata\fR is supplied, it is a compression dictionary to use. Note that +there are no checks in place to determine whether the compression dictionary +is correct. +.VE .RE .SS "CHECKSUMMING SUBCOMMANDS" .TP @@ -356,10 +375,10 @@ supported (or an unambiguous prefix of them), which are used to modify the way in which the transformation is applied: .RS .TP -\fB\-dictionary\fI compressionDictionary\fR +\fB\-dictionary\fI binData\fR .VS "TIP 400" -Sets a compression dictionary to use when working with compressing or -decompressing the data. +Sets the compression dictionary to use when working with compressing or +decompressing the data to be \fIbinData\fR. .VE .TP \fB\-finalize\fR -- cgit v0.12 From 124e26e763eb211d3514574042b714fc92dcbf14 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Aug 2012 13:58:25 +0000 Subject: Add 64-bit build of zlib1.dll, and use it for the dynamic mingw-w64 build --- ChangeLog | 8 ++++++++ compat/zlib/win64/zdll.lib | Bin 0 -> 45650 bytes compat/zlib/win64/zlib1.dll | Bin 0 -> 112640 bytes win/Makefile.in | 8 ++++++-- win/configure | 14 ++++++++++++-- win/configure.in | 8 ++++++-- 6 files changed, 32 insertions(+), 6 deletions(-) create mode 100644 compat/zlib/win64/zdll.lib create mode 100644 compat/zlib/win64/zlib1.dll diff --git a/ChangeLog b/ChangeLog index 4391648..e1eb9b8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-08-13 Jan Nijtmans + + * compat/zlib/win64/zlib1.dll: Add 64-bit build of zlib1.dll, and use it + * compat/zlib/win64/zdll.lib: for the dynamic mingw-w64 build. + * win/Makefile.in + * win/configure.in + * win/configure + 2012-08-09 Reinhard Max * tests/http.test: Fix http-3.29 for machines without IPv6 support. diff --git a/compat/zlib/win64/zdll.lib b/compat/zlib/win64/zdll.lib new file mode 100644 index 0000000..084dbff Binary files /dev/null and b/compat/zlib/win64/zdll.lib differ diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll new file mode 100644 index 0000000..631439b Binary files /dev/null and b/compat/zlib/win64/zlib1.dll differ diff --git a/win/Makefile.in b/win/Makefile.in index 84dcaf7..fbc9274 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -456,8 +456,12 @@ ${TEST_DLL_FILE}: ${TCLTEST_OBJS} ${TCL_STUB_LIB_FILE} @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) # use pre-built zlib1.dll -${ZLIB_DLL_FILE}: $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} - @$(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE} +${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} + if test "@ZLIB_LIBS@set" == "${ZLIB_DIR}/win64/zdll.libset" ; then \ + $(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ + else \ + $(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ + fi; # Add the object extension to the implicit rules. By default .obj is not # automatically added. diff --git a/win/configure b/win/configure index f5a23fe..5cf1513 100755 --- a/win/configure +++ b/win/configure @@ -4344,7 +4344,7 @@ esac # as we just assume that the platform hasn't got a usable z.lib #------------------------------------------------------------------------ -if test "$do64bit" = "yes"; then +if test "$do64bit" = "yes" && test "$GCC" != "yes"; then tcl_ok=no @@ -4368,7 +4368,17 @@ if test "$tcl_ok" = "yes"; then ZLIB_DLL_FILE=\${ZLIB_DLL_FILE} - ZLIB_LIBS=\${ZLIB_DIR}/win32/zdll.lib + if test "$do64bit" = "yes"; then + + ZLIB_LIBS=\${ZLIB_DIR}/win64/zdll.lib + + +else + + ZLIB_LIBS=\${ZLIB_DIR}/win32/zdll.lib + + +fi else diff --git a/win/configure.in b/win/configure.in index d17f815..de56bf7 100644 --- a/win/configure.in +++ b/win/configure.in @@ -120,7 +120,7 @@ esac # as we just assume that the platform hasn't got a usable z.lib #------------------------------------------------------------------------ -AS_IF([test "$do64bit" = "yes"], [ +AS_IF([test "$do64bit" = "yes" && test "$GCC" != "yes"], [ tcl_ok=no ], [ AS_IF([test "${enable_shared+set}" = "set"], [ @@ -132,7 +132,11 @@ AS_IF([test "${enable_shared+set}" = "set"], [ ]) AS_IF([test "$tcl_ok" = "yes"], [ AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win32/zdll.lib]) + AS_IF([test "$do64bit" = "yes"], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win64/zdll.lib]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win32/zdll.lib]) + ]) ], [ AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) AC_DEFINE_UNQUOTED(NO_VIZ, 1) -- cgit v0.12 From 1e2e2f72bdd4b29f882d15af731d3c222cc1d7f9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Aug 2012 14:02:23 +0000 Subject: .... but be less verbose --- win/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/Makefile.in b/win/Makefile.in index fbc9274..392bd7a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -457,7 +457,7 @@ ${TEST_DLL_FILE}: ${TCLTEST_OBJS} ${TCL_STUB_LIB_FILE} # use pre-built zlib1.dll ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} - if test "@ZLIB_LIBS@set" == "${ZLIB_DIR}/win64/zdll.libset" ; then \ + @if test "@ZLIB_LIBS@set" == "${ZLIB_DIR}/win64/zdll.libset" ; then \ $(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ else \ $(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ -- cgit v0.12 From d91cd78b69e53b8a94d4751419238c230ec4b6f9 Mon Sep 17 00:00:00 2001 From: stwo Date: Mon, 13 Aug 2012 14:18:55 +0000 Subject: [Bug 3555454] Rearrange a bit to quash 'declared but never defined' compiler warnings. --- ChangeLog | 5 +++++ unix/tclUnixCompat.c | 16 ++++++++++------ 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/ChangeLog b/ChangeLog index e1eb9b8..cc70f44 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2010-08-13 Stuart Cassoff + + * unix/tclUnixCompat.c: [Bug 3555454] Rearrange a bit + to quash 'declared but never defined' compiler warnings. + 2012-08-13 Jan Nijtmans * compat/zlib/win64/zlib1.dll: Add 64-bit build of zlib1.dll, and use it diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 359e253..e201018 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -99,12 +99,20 @@ static Tcl_Mutex compatLock; #undef NEED_COPYPWD #undef NEED_COPYSTRING +#if !defined(HAVE_GETGRNAM_R_5) && !defined(HAVE_GETGRNAM_R_4) +#define NEED_COPYGRP 1 +static int CopyGrp(struct group *tgtPtr, char *buf, int buflen); +#endif + +#if !defined(HAVE_GETPWNAM_R_5) && !defined(HAVE_GETPWNAM_R_4) +#define NEED_COPYPWD 1 +static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); +#endif + static int CopyArray(char **src, int elsize, char *buf, int buflen); -static int CopyGrp(struct group *tgtPtr, char *buf, int buflen); static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); -static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif @@ -214,7 +222,6 @@ TclpGetPwNam( return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); #else -#define NEED_COPYPWD 1 struct passwd *pwPtr; Tcl_MutexLock(&compatLock); @@ -295,7 +302,6 @@ TclpGetPwUid( return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); #else -#define NEED_COPYPWD 1 struct passwd *pwPtr; Tcl_MutexLock(&compatLock); @@ -399,7 +405,6 @@ TclpGetGrNam( return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); #else -#define NEED_COPYGRP 1 struct group *grPtr; Tcl_MutexLock(&compatLock); @@ -480,7 +485,6 @@ TclpGetGrGid( return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); #else -#define NEED_COPYGRP 1 struct group *grPtr; Tcl_MutexLock(&compatLock); -- cgit v0.12 From 4e74361197fa82542a778b3b64310c1696ff747a Mon Sep 17 00:00:00 2001 From: stwo Date: Mon, 13 Aug 2012 22:27:14 +0000 Subject: [Bug 3555454] Rearrange a bit to quash 'declared but never defined' compiler warnings. --- ChangeLog | 5 +++++ unix/tclUnixCompat.c | 16 ++++++++++------ 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/ChangeLog b/ChangeLog index d6499d7..5374478 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2010-08-13 Stuart Cassoff + + * unix/tclUnixCompat.c: [Bug 3555454] Rearrange a bit + to quash 'declared but never defined' compiler warnings. + 2012-08-08 Jan Nijtmans * generic/tclfileName.c: [Bug #1536227]: Cygwin network pathname diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 8b067af..06c19b9 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -99,12 +99,20 @@ static Tcl_Mutex compatLock; #undef NEED_COPYPWD #undef NEED_COPYSTRING +#if !defined(HAVE_GETGRNAM_R_5) && !defined(HAVE_GETGRNAM_R_4) +#define NEED_COPYGRP 1 +static int CopyGrp(struct group *tgtPtr, char *buf, int buflen); +#endif + +#if !defined(HAVE_GETPWNAM_R_5) && !defined(HAVE_GETPWNAM_R_4) +#define NEED_COPYPWD 1 +static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); +#endif + static int CopyArray(char **src, int elsize, char *buf, int buflen); -static int CopyGrp(struct group *tgtPtr, char *buf, int buflen); static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); -static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif @@ -214,7 +222,6 @@ TclpGetPwNam( return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); #else -#define NEED_COPYPWD 1 struct passwd *pwPtr; Tcl_MutexLock(&compatLock); @@ -295,7 +302,6 @@ TclpGetPwUid( return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); #else -#define NEED_COPYPWD 1 struct passwd *pwPtr; Tcl_MutexLock(&compatLock); @@ -399,7 +405,6 @@ TclpGetGrNam( return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); #else -#define NEED_COPYGRP 1 struct group *grPtr; Tcl_MutexLock(&compatLock); @@ -480,7 +485,6 @@ TclpGetGrGid( return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); #else -#define NEED_COPYGRP 1 struct group *grPtr; Tcl_MutexLock(&compatLock); -- cgit v0.12 From 23f6ebe4d98a88d341bba40fdc4bfc5ffcd98a62 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Aug 2012 08:12:39 +0000 Subject: Only build the threaded builds by default. Backport some improvements from Tcl 8.6 --- ChangeLog | 6 +++ win/buildall.vc.bat | 68 +++++++++-------------- win/makefile.vc | 153 +++++++++++++++++++++++++++++++++++----------------- win/rules.vc | 63 ++++++++++++++-------- 4 files changed, 175 insertions(+), 115 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5374478..9956dd0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2012-08-15 Jan Nijtmans + + * win/buildall.vc.bat: Only build the threaded builds by default + * win/rules.vc: Backport some improvements from Tcl 8.6 + * win/makefile.vc: + 2010-08-13 Stuart Cassoff * unix/tclUnixCompat.c: [Bug 3555454] Rearrange a bit diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat index 55b29ae..0c9b3ac 100644 --- a/win/buildall.vc.bat +++ b/win/buildall.vc.bat @@ -1,4 +1,5 @@ @echo off + :: This is an example batchfile for building everything. Please :: edit this (or make your own) for your needs and wants using :: the instructions for calling makefile.vc found in makefile.vc @@ -22,17 +23,25 @@ goto OPTIONS_DONE :: reset errorlevel cd > nul +:: You might have installed your developer studio to add itself to the +:: path or have already run vcvars32.bat. Testing these envars proves +:: cl.exe and friends are in your path. +:: +if defined VCINSTALLDIR (goto :startBuilding) +if defined MSDEVDIR (goto :startBuilding) +if defined MSVCDIR (goto :startBuilding) +if defined MSSDK (goto :startBuilding) +if defined WINDOWSSDKDIR (goto :startBuilding) + :: We need to run the development environment batch script that comes -:: with developer studio (v4,5,6,7,etc...) All have it. These paths -:: might not be correct. You may need to edit these. +:: with developer studio (v4,5,6,7,etc...) All have it. This path +:: might not be correct. You should call it yourself prior to running +:: this batchfile. :: -if not defined MSDevDir ( - call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat" - ::call "C:\Program Files\Microsoft Developer Studio\vc\bin\vcvars32.bat" - ::call c:\dev\devstudio60\vc98\bin\vcvars32.bat - if errorlevel 1 goto no_vcvars -) +call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat" +if errorlevel 1 (goto no_vcvars) +:startBuilding echo. echo Sit back and have a cup of coffee while this grinds through ;) @@ -50,45 +59,16 @@ if "%INSTALLDIR%" == "" set INSTALLDIR=C:\Program Files\Tcl :: Build the normal stuff along with the help file. :: -set OPTS=none -if not %SYMBOLS%.==. set OPTS=symbols -nmake -nologo -f makefile.vc release winhelp OPTS=%OPTS% %1 -if errorlevel 1 goto error - -:: Build the static core, dlls and shell. -:: -set OPTS=static -if not %SYMBOLS%.==. set OPTS=symbols,static -nmake -nologo -f makefile.vc release OPTS=%OPTS% %1 -if errorlevel 1 goto error - -:: Build the special static libraries that use the dynamic runtime. -:: -set OPTS=static,msvcrt -if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt -nmake -nologo -f makefile.vc core dlls OPTS=%OPTS% %1 -if errorlevel 1 goto error - -:: Build the core and shell for thread support. -:: set OPTS=threads if not %SYMBOLS%.==. set OPTS=symbols,threads -nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1 -if errorlevel 1 goto error - -:: Build a static, thread support core library with a shell. -:: -set OPTS=static,threads -if not %SYMBOLS%.==. set OPTS=symbols,static,threads -nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1 +nmake -nologo -f makefile.vc release winhelp OPTS=%OPTS% %1 if errorlevel 1 goto error -:: Build the special static libraries that use the dynamic runtime, -:: but now with thread support. +:: Build the static core and shell. :: set OPTS=static,msvcrt,threads if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt,threads -nmake -nologo -f makefile.vc core dlls OPTS=%OPTS% %1 +nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1 if errorlevel 1 goto error set OPTS= @@ -100,15 +80,15 @@ echo *** BOOM! *** goto end :no_vcvars -echo vcvars32.bat not found. You'll need to edit this batch script. +echo vcvars32.bat was not run prior to this batchfile, nor are the MS tools in your path. goto out :help title buildall.vc.bat help message echo usage: -echo %0 : builds Tcl for all build types (do this first) -echo %0 install : installs all the release builds (do this second) -echo %0 symbols : builds Tcl for all debugging build types +echo %0 : builds Tcl for all build types (do this first) +echo %0 install : installs all the release builds (do this second) +echo %0 symbols : builds Tcl for all debugging build types echo %0 symbols install : install all the debug builds. echo. goto out diff --git a/win/makefile.vc b/win/makefile.vc index 5db8143..3d17331 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -5,7 +5,7 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# +# # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. @@ -58,67 +58,72 @@ the build instructions. # makefile. Helpful to avoid problems when the sources are # refreshed and you rebuild, but can "overbuild" when common # headers like tclInt.h just get small changes. +# htmlhelp -- Builds a Windows .chm help file for Tcl and Tk from the +# troff manual pages found in $(ROOT)\doc. You need to +# have installed the HTML Help Compiler package from Microsoft +# to produce the .chm file. # winhelp -- Builds the windows .hlp file for Tcl from the troff man -# files found in $(ROOT)\doc . +# files found in $(ROOT)\doc. # # 4) Macros usable on the commandline: # INSTALLDIR= # Sets where to install Tcl from the built binaries. # C:\Progra~1\Tcl is assumed when not specified. # -# OPTS=static,msvcrt,staticpkg,threads,symbols,profile,loimpact,unchecked,none +# OPTS=loimpact,msvcrt,static,staticpkg,symbols,threads,profile,unchecked,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. # -# static = Builds a static library of the core instead of a -# dll. The shell will be static (and large), as well. -# msvcrt = Affects the static option only to switch it from +# loimpact = Adds a flag for how NT treats the heap to keep memory +# in use, low. This is said to impact alloc performance. +# msvcrt = Affects the static option only to switch it from # using libcmt(d) as the C runtime [by default] to # msvcrt(d). This is useful for static embedding # support. -# staticpkg = Affects the static option only to switch +# static = Builds a static library of the core instead of a +# dll. The shell will be static (and large), as well. +# staticpkg= Affects the static option only to switch # tclshXX.exe to have the dde and reg extension linked # inside it. -# threads = Turns on full multithreading support. +# threads = Turns on full multithreading support. # thrdalloc = Use the thread allocator (shared global free pool). # thrdstorage = Use the generic thread storage support. # symbols = Adds symbols for step debugging. # profile = Adds profiling hooks. Map file is assumed. -# loimpact = Adds a flag for how NT treats the heap to keep memory -# in use, low. This is said to impact alloc performance. # unchecked = Allows a symbols build to not use the debug # enabled runtime (msvcrt.dll not msvcrtd.dll # or libcmt.lib not libcmtd.lib). # -# STATS=memdbg,compdbg,none +# STATS=compdbg,memdbg,none # Sets optional memory and bytecode compiler debugging code added # to the core. The default is for none. Any combination of the # above may be used (comma separated). 'none' will over-ride # everything to nothing. # -# memdbg = Enables the debugging memory allocator. # compdbg = Enables byte compilation logging. +# memdbg = Enables the debugging memory allocator. # -# CHECKS=nodep,fullwarn,64bit,none +# CHECKS=64bit,fullwarn,nodep,none # Sets special macros for checking compatability. # -# nodep = Turns off compatability macros to ensure the core -# isn't being built with deprecated functions. +# 64bit = Enable 64bit portability warnings (if available) # fullwarn = Builds with full compiler and link warnings enabled. # Very verbose. -# 64bit = Enable 64bit portability warnings (if available) +# nodep = Turns off compatability macros to ensure the core +# isn't being built with deprecated functions. # -# MACHINE=(IX86|IA64|AMD64|ALPHA) +# MACHINE=(ALPHA|AMD64|IA64|IX86) # Set the machine type used for the compiler, linker, and # resource compiler. This hook is needed to tell the tools # when alternate platforms are requested. IX86 is the default -# when not specified. +# when not specified. If the CPU environment variable has been +# set (ie: recent Platform SDK) then MACHINE is set from CPU. # # TMP_DIR= # OUT_DIR= # Hooks to allow the intermediate and output directories to be -# changed. $(OUT_DIR) is assumed to be +# changed. $(OUT_DIR) is assumed to be # $(BINROOT)\(Release|Debug) based on if symbols are requested. # $(TMP_DIR) will de $(OUT_DIR)\ by default. # @@ -170,7 +175,7 @@ Please `cd` to its location first. !error $(MSG) !endif -PROJECT = tcl +PROJECT = tcl !include "rules.vc" STUBPREFIX = $(PROJECT)stub @@ -397,7 +402,8 @@ TCLOBJS = \ $(TMP_DIR)\tcl.res !endif -TCLSTUBOBJS = $(TMP_DIR)\tclStubLib.obj +TCLSTUBOBJS = \ + $(TMP_DIR)\tclStubLib.obj ### The following paths CANNOT have spaces in them. COMPATDIR = $(ROOT)\compat @@ -407,7 +413,6 @@ TOMMATHDIR = $(ROOT)\libtommath TOOLSDIR = $(ROOT)\tools WINDIR = $(ROOT)\win - #--------------------------------------------------------------------- # Compile flags #--------------------------------------------------------------------- @@ -452,8 +457,7 @@ TCL_DEFINES = -DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\" -DTCL_TOMMATH -DMP_PREC=4 -Di BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) $(TCL_DEFINES) CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES) -### Stubs files should not be compiled with -GL -STUB_CFLAGS = $(cflags) $(cdebug:-GL=) $(OPTDEFINES) +STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES) #--------------------------------------------------------------------- @@ -522,17 +526,17 @@ all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) tcltest: setup $(TCLTEST) dlls $(CAT32) install: install-binaries install-libraries install-docs - -test: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT)/library +test: test-core +test-core: setup $(TCLTEST) dlls $(CAT32) + set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" - $(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) -loadfile << + $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.3.3 [list load "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.2.2 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... - $(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log + $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.2.2 "$(TCLREGLIB:\=/)" registry] << @@ -540,8 +544,12 @@ test: setup $(TCLTEST) dlls $(CAT32) !endif runtest: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT)/library - $(DEBUGGER) $(TCLTEST) + set TCL_LIBRARY=$(ROOT:\=/)/library + $(DEBUGGER) $(TCLTEST) $(SCRIPT) + +runshell: setup $(TCLSH) dlls + set TCL_LIBRARY=$(ROOT:\=/)/library + $(DEBUGGER) $(TCLSH) $(SCRIPT) setup: @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) @@ -553,7 +561,7 @@ $(TCLIMPLIB): $(TCLLIB) $(TCLLIB): $(TCLOBJS) !if $(STATIC_BUILD) - $(lib32) -nologo -out:$@ @<< + $(lib32) -nologo $(LINKERFLAGS) -out:$@ @<< $** << !else @@ -566,13 +574,13 @@ $** !endif $(TCLSTUBLIB): $(TCLSTUBOBJS) - $(lib32) -nologo -out:$@ $(TCLSTUBOBJS) + $(lib32) -nologo $(LINKERFLAGS) -out:$@ $(TCLSTUBOBJS) -$(TCLSH): $(TCLSHOBJS) $(TCLIMPLIB) +$(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** $(_VC_MANIFEST_EMBED_EXE) -$(TCLTEST): $(TCLTESTOBJS) $(TCLIMPLIB) +$(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** $(_VC_MANIFEST_EMBED_EXE) @@ -583,7 +591,7 @@ $(TCLPIPEDLL): $(WINDIR)\stub16.c !if $(STATIC_BUILD) $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj - $(lib32) -nologo -out:$@ $** + $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** !else $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB) $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \ @@ -595,7 +603,7 @@ $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB) !if $(STATIC_BUILD) $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj - $(lib32) -nologo -out:$@ $** + $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** !else $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \ @@ -641,9 +649,49 @@ gentommath_h: !endif #--------------------------------------------------------------------- -# Build the windows help file. +# Build the Windows HTML help file. #--------------------------------------------------------------------- +# NOTE: you can define HHC on the command-line to override this +!ifndef HHC +HHC=""%ProgramFiles%\HTML Help Workshop\hhc.exe"" +!endif +HTMLDIR=$(ROOT)\html +HTMLBASE=TclTk$(VERSION) +HHPFILE=$(HTMLDIR)\$(HTMLBASE).hhp +CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm + +htmlhelp: chmsetup $(CHMFILE) + +$(CHMFILE): $(DOCDIR)\* + @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl + @echo Compiling HTML help project + @$(HHC) <<$(HHPFILE) >NUL +[OPTIONS] +Compatibility=1.1 or later +Compiled file=$(HTMLBASE).chm +Display compile progress=no +Error log file=$(HTMLBASE).log +Language=0x409 English (United States) +Title=Tcl/Tk $(DOT_VERSION) Help +[FILES] +contents.htm +docs.css +Keywords +TclCmd +TclLib +TkCmd +TkLib +UserCmd +<< + +chmsetup: + @if not exist $(HTMLDIR)\nul mkdir $(HTMLDIR) + +#------------------------------------------------------------------------- +# Build the old-style Windows .hlp file +#------------------------------------------------------------------------- + TCLHLPBASE = $(PROJECT)$(VERSION) HELPFILE = $(OUT_DIR)\$(TCLHLPBASE).hlp HELPCNT = $(OUT_DIR)\$(TCLHLPBASE).cnt @@ -701,7 +749,12 @@ $(HELPRTF): $(MAN2TCL) $(MAN2HELP) $(MAN2HELP2) $(INDEX) $(DOCDIR)\* $(TCLSH) $(MAN2HELP) -bitmap $(BMP_NOPATH) $(PROJECT) $(VERSION) $(DOCDIR:\=/) install-docs: -!if exist($(HELPFILE)) +!if exist("$(CHMFILE)") + @echo Installing compiled HTML help + @$(CPY) "$(CHMFILE)" "$(DOC_INSTALL_DIR)\" +!endif +!if exist("$(HELPFILE)") + @echo Installing Windows help @$(CPY) "$(HELPFILE)" "$(DOC_INSTALL_DIR)\" @$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\" !endif @@ -732,8 +785,8 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in @LIBS@ $(baselibs) @prefix@ $(_INSTALLDIR) @exec_prefix@ $(BIN_INSTALL_DIR) -@SHLIB_CFLAGS@ -@STLIB_CFLAGS@ +@SHLIB_CFLAGS@ +@STLIB_CFLAGS@ @CFLAGS_WARNING@ -W3 @EXTRA_CFLAGS@ -YX @SHLIB_LD@ $(link32) $(dlllflags) @@ -751,7 +804,7 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in @TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR) @TCL_LIB_VERSIONS_OK@ @TCL_SRC_DIR@ $(ROOT) -@TCL_PACKAGE_PATH@ +@TCL_PACKAGE_PATH@ @TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME) @@ -771,7 +824,7 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in #--------------------------------------------------------------------- -# The following target generates the file generic/tclDate.c +# The following target generates the file generic/tclDate.c # from the yacc grammar found in generic/tclGetDate.y. This is # only run by hand as yacc is not available in all environments. # The name of the .c file is different than the name of the .y file @@ -1023,15 +1076,15 @@ install-libraries: tclConfig install-msgs install-tzdata install-tzdata: @echo Installing time zone data - @set TCL_LIBRARY=$(ROOT)/library - @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \ - "$(ROOT)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" install-msgs: @echo Installing message catalogs - @set TCL_LIBRARY=$(ROOT)/library - @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \ - "$(ROOT)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" #--------------------------------------------------------------------- # Clean up @@ -1069,6 +1122,8 @@ clean: @echo Cleaning $(WINDIR)\versions.vc ... @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc +realclean: hose + hose: @echo Hosing $(OUT_DIR)\* ... @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) diff --git a/win/rules.vc b/win/rules.vc index 20c967a..bbf7485 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -6,9 +6,9 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# +# # Copyright (c) 2001-2003 David Gravereaux. -# Copyright (c) 2003-2007 Patrick Thoyts +# Copyright (c) 2003-2008 Patrick Thoyts #------------------------------------------------------------------------------ !ifndef _RULES_VC @@ -217,7 +217,8 @@ TCL_THREADS = 0 DEBUG = 0 SYMBOLS = 0 PROFILE = 0 -MSVCRT = 0 +PGO = 0 +MSVCRT = 1 LOIMPACT = 0 TCL_USE_STATIC_PACKAGES = 0 USE_THREAD_ALLOC = 0 @@ -233,9 +234,13 @@ STATIC_BUILD = 0 !message *** Doing msvcrt MSVCRT = 1 !else +!if !$(STATIC_BUILD) +MSVCRT = 1 +!else MSVCRT = 0 !endif -!if [nmakehlp -f $(OPTS) "staticpkg"] +!endif +!if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !else @@ -244,8 +249,10 @@ TCL_USE_STATIC_PACKAGES = 0 !if [nmakehlp -f $(OPTS) "threads"] !message *** Doing threads TCL_THREADS = 1 +USE_THREAD_ALLOC = 1 !else TCL_THREADS = 0 +USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols @@ -265,6 +272,15 @@ PROFILE = 1 !else PROFILE = 0 !endif +!if [nmakehlp -f $(OPTS) "pgi"] +!message *** Doing profile guided optimization instrumentation +PGO = 1 +!elseif [nmakehlp -f $(OPTS) "pgo"] +!message *** Doing profile guided optimization +PGO = 2 +!else +PGO = 0 +!endif !if [nmakehlp -f $(OPTS) "loimpact"] !message *** Doing loimpact LOIMPACT = 1 @@ -274,7 +290,9 @@ LOIMPACT = 0 !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 -!else +!endif +!if [nmakehlp -f $(OPTS) "tclalloc"] +!message *** Doing tclalloc USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] @@ -285,15 +303,6 @@ UNCHECKED = 0 !endif !endif - -!if !$(STATIC_BUILD) -# Make sure we don't build overly fat DLLs. -MSVCRT = 1 -# We shouldn't statically put the extensions inside the shell when dynamic. -TCL_USE_STATIC_PACKAGES = 0 -!endif - - #---------------------------------------------------------- # Figure-out how to name our intermediate and output directories. # We wouldn't want different builds to use the same .obj files @@ -335,10 +344,8 @@ TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX TMP_DIRFULL = $(TMP_DIRFULL:Static=) SUFX = $(SUFX:s=) EXT = dll -!if $(MSVCRT) TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) -!endif !else TMP_DIRFULL = $(TMP_DIRFULL:Dynamic=) EXT = lib @@ -417,6 +424,24 @@ WARNINGS = $(WARNINGS) -Wp64 !endif !endif +!if $(PGO) > 1 +!if [nmakehlp -l -ltcg:pgoptimize] +LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pgoptimize +!else +MSG=^ +This compiler does not support profile guided optimization. +!error $(MSG) +!endif +!elseif $(PGO) > 0 +!if [nmakehlp -l -ltcg:pginstrument] +LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pginstrument +!else +MSG=^ +This compiler does not support profile guided optimization. +!error $(MSG) +!endif +!endif + #---------------------------------------------------------- # Set our defines now armed with our options. #---------------------------------------------------------- @@ -552,12 +577,6 @@ Failed to find tcl.h. The TCLDIR macro does not appear correct. TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) -!if $(TCL_VERSION) < 81 -TCL_DOES_STUBS = 0 -!else -TCL_DOES_STUBS = 1 -!endif - !if $(TCLINSTALL) TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe" !if !exist($(TCLSH)) && $(TCL_THREADS) -- cgit v0.12 From ffdb1309cbab550b498d3da05f7a38bcddd5c65a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Aug 2012 08:41:03 +0000 Subject: build htmlhelp, not winhelp by default --- win/buildall.vc.bat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat index fed5e64..e4f0a30 100755 --- a/win/buildall.vc.bat +++ b/win/buildall.vc.bat @@ -61,7 +61,7 @@ if "%INSTALLDIR%" == "" set INSTALLDIR=C:\Program Files\Tcl :: set OPTS=none if not %SYMBOLS%.==. set OPTS=symbols -nmake -nologo -f makefile.vc release winhelp OPTS=%OPTS% %1 +nmake -nologo -f makefile.vc release htmlhelp OPTS=%OPTS% %1 if errorlevel 1 goto error :: Build the static core and shell. -- cgit v0.12 From f6d1c13f662de1a5aaa30a0fc765efdda8bd0cbe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Aug 2012 07:15:31 +0000 Subject: nmakehlp: Add "-V" option, in order to be able to detect partial version numbers. --- win/nmakehlp.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/win/nmakehlp.c b/win/nmakehlp.c index 2868857..d0edcf0 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -47,7 +47,7 @@ static int CheckForLinkerFeature(const char *option); static int IsIn(const char *string, const char *substring); static int SubstituteFile(const char *substs, const char *filename); static int QualifyPath(const char *path); -static const char *GetVersionFromFile(const char *filename, const char *match); +static const char *GetVersionFromFile(const char *filename, const char *match, int numdots); static DWORD WINAPI ReadFromPipe(LPVOID args); /* globals */ @@ -153,7 +153,7 @@ main( &dwWritten, NULL); return 0; } - printf("%s\n", GetVersionFromFile(argv[2], argv[3])); + printf("%s\n", GetVersionFromFile(argv[2], argv[3], *(argv[1]+2) - '0')); return 0; case 'Q': if (argc != 3) { @@ -479,7 +479,8 @@ IsIn( static const char * GetVersionFromFile( const char *filename, - const char *match) + const char *match, + int numdots) { size_t cbBuffer = 100; static char szBuffer[100]; @@ -509,7 +510,8 @@ GetVersionFromFile( */ q = p; - while (*q && (isalnum(*q) || *q == '.')) { + while (*q && (strchr("0123456789.ab", *q)) && ((!strchr(".ab", *q) + && (!strchr("ab", q[-1])) || --numdots))) { ++q; } -- cgit v0.12 From 27afab02c122b709b82df84cc64e01e4984fa9a0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Aug 2012 07:16:25 +0000 Subject: nmakehlp: Add "-V" option, in order to be able to detect partial version numbers. --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 77d483d..b8b9f2b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-17 Jan Nijtmans + + * win/nmakehlp.c: Add "-V" option, in order to be able + to detect partial version numbers. + 2012-07-31 Jan Nijtmans * win/nmakehlp.c: Backport from Tcl 8.6, but add -Q option from -- cgit v0.12 From 9aa711e8e0c11bcdda23542d82c44a773e07251c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Aug 2012 06:49:25 +0000 Subject: remove unnecessary struct names, which only pollute the "struct" namespace for te compiler. --- generic/regc_locale.c | 2 +- generic/tcl.h | 2 +- generic/tclBasic.c | 2 +- generic/tclBinary.c | 2 +- generic/tclCkalloc.c | 2 +- generic/tclClock.c | 4 ++-- generic/tclCmdIL.c | 2 +- generic/tclCompExpr.c | 2 +- generic/tclCompile.h | 8 ++++---- generic/tclConfig.c | 2 +- generic/tclEncoding.c | 8 ++++---- generic/tclEvent.c | 2 +- generic/tclExecute.c | 2 +- generic/tclIO.c | 2 +- generic/tclIOCmd.c | 4 ++-- generic/tclIORChan.c | 8 ++++---- generic/tclIORTrans.c | 8 ++++---- generic/tclIOUtil.c | 4 ++-- generic/tclInterp.c | 16 ++++++++-------- generic/tclLink.c | 2 +- generic/tclMain.c | 2 +- generic/tclNamesp.c | 4 ++-- generic/tclObj.c | 2 +- generic/tclPathObj.c | 2 +- generic/tclPkg.c | 2 +- generic/tclPreserve.c | 2 +- generic/tclRegexp.c | 2 +- generic/tclResult.c | 2 +- generic/tclScan.c | 2 +- generic/tclStringObj.c | 2 +- generic/tclTest.c | 6 +++--- generic/tclTestObj.c | 2 +- generic/tclTestProcBodyObj.c | 2 +- generic/tclThreadAlloc.c | 2 +- generic/tclThreadStorage.c | 2 +- generic/tclThreadTest.c | 2 +- generic/tclTimer.c | 2 +- generic/tclTrace.c | 2 +- unix/tclUnixChan.c | 4 ++-- unix/tclUnixCompat.c | 2 +- unix/tclUnixInit.c | 8 ++++---- unix/tclUnixNotfy.c | 4 ++-- unix/tclUnixPipe.c | 2 +- unix/tclUnixTest.c | 2 +- unix/tclUnixThrd.c | 8 ++++---- unix/tclUnixTime.c | 2 +- win/tclWinChan.c | 4 ++-- win/tclWinConsole.c | 6 +++--- win/tclWinDde.c | 24 ++++++++++++------------ win/tclWinNotify.c | 2 +- win/tclWinPipe.c | 6 +++--- win/tclWinSerial.c | 4 ++-- win/tclWinSock.c | 4 ++-- win/tclWinThrd.c | 8 ++++---- win/tclWinTime.c | 4 ++-- 55 files changed, 110 insertions(+), 110 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 40791f4..d01888b 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -118,7 +118,7 @@ static const struct cname { * Unicode character-class tables. */ -typedef struct crange { +typedef struct { chr start; chr end; } crange; diff --git a/generic/tcl.h b/generic/tcl.h index 729e521..7a026ed 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -458,7 +458,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; typedef struct _stat32i64 Tcl_StatBuf; # endif /* _MSC_VER < 1400 */ #elif defined(__CYGWIN__) - typedef struct _stat32i64 { + typedef struct { dev_t st_dev; unsigned short st_ino; unsigned short st_mode; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index db365e3..d47d96f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -45,7 +45,7 @@ * registered with Tcl_CreateMathFunc */ -typedef struct OldMathFuncData { +typedef struct { Tcl_MathProc *proc; /* Handler function */ int numArgs; /* Number of args expected */ Tcl_ValueType *argTypes; /* Types of the args */ diff --git a/generic/tclBinary.c b/generic/tclBinary.c index a1e836e..5e1114d 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -167,7 +167,7 @@ const Tcl_ObjType tclByteArrayType = { * fewer mallocs. */ -typedef struct ByteArray { +typedef struct { int used; /* The number of bytes used in the byte * array. */ int allocated; /* The amount of space actually allocated diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index ab977cb..2268e45 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -33,7 +33,7 @@ * "memory tag" command is invoked, to hold the current tag. */ -typedef struct MemTag { +typedef struct { int refCount; /* Number of mem_headers referencing this * tag. */ char string[1]; /* Actual size of string will be as large as diff --git a/generic/tclClock.c b/generic/tclClock.c index 6d2976d..1257231 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -91,7 +91,7 @@ static const char *const literals[] = { * Structure containing the client data for [clock] */ -typedef struct ClockClientData { +typedef struct { int refCount; /* Number of live references. */ Tcl_Obj **literals; /* Pool of object literals. */ } ClockClientData; @@ -100,7 +100,7 @@ typedef struct ClockClientData { * Structure containing the fields used in [clock format] and [clock scan] */ -typedef struct TclDateFields { +typedef struct { Tcl_WideInt seconds; /* Time expressed in seconds from the Posix * epoch */ Tcl_WideInt localSeconds; /* Local time expressed in nominal seconds diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 14e0092..c0c1030 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -56,7 +56,7 @@ typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t); * The following structure is used to pass this information. */ -typedef struct SortInfo { +typedef struct { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below. */ diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 890d518..c7aebba 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -22,7 +22,7 @@ * The tree is composed of OpNodes. */ -typedef struct OpNode { +typedef struct { int left; /* "Pointer" to the left operand. */ int right; /* "Pointer" to the right operand. */ union { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ba78c36..82a4218 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -80,7 +80,7 @@ typedef enum { * to a catch PC offset. */ } ExceptionRangeType; -typedef struct ExceptionRange { +typedef struct { ExceptionRangeType type; /* The kind of ExceptionRange. */ int nestingLevel; /* Static depth of the exception range. Used * to find the most deeply-nested range @@ -107,7 +107,7 @@ typedef struct ExceptionRange { * source offset is not monotonic. */ -typedef struct CmdLocation { +typedef struct { int codeOffset; /* Offset of first byte of command code. */ int numCodeBytes; /* Number of bytes for command's code. */ int srcOffset; /* Offset of first char of the command. */ @@ -125,7 +125,7 @@ typedef struct CmdLocation { * frame and associated information, like the path of a sourced file. */ -typedef struct ECL { +typedef struct { int srcOffset; /* Command location to find the entry. */ int nline; /* Number of words in the command */ int *line; /* Line information for all words in the @@ -135,7 +135,7 @@ typedef struct ECL { * lines. */ } ECL; -typedef struct ExtCmdLoc { +typedef struct { int type; /* Context type. */ int start; /* Starting line for compiled script. Needed * for the extended recompile check in diff --git a/generic/tclConfig.c b/generic/tclConfig.c index a4ba71a..fe99bbb 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -31,7 +31,7 @@ * and the (Tcl_Interp *) in which it is stored. */ -typedef struct QCCD { +typedef struct { Tcl_Obj *pkg; Tcl_Interp *interp; } QCCD; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 7a55724..8f30471 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -18,7 +18,7 @@ typedef size_t (LengthProc)(const char *src); * convert between various character sets and UTF-8. */ -typedef struct Encoding { +typedef struct { char *name; /* Name of encoding. Malloced because (1) hash * table entry that owns this encoding may be * freed prior to this encoding being freed, @@ -57,7 +57,7 @@ typedef struct Encoding { * encoding. */ -typedef struct TableEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ @@ -91,7 +91,7 @@ typedef struct TableEncodingData { * for switching character sets. */ -typedef struct EscapeSubTable { +typedef struct { unsigned sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ char name[32]; /* Name for encoding. */ @@ -100,7 +100,7 @@ typedef struct EscapeSubTable { * yet. */ } EscapeSubTable; -typedef struct EscapeEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 0b585b6..fb5e9c5 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -37,7 +37,7 @@ typedef struct BgError { * pending background errors for the interpreter. */ -typedef struct ErrAssocData { +typedef struct { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ BgError *firstBgPtr; /* First in list of all background errors diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3c0b472..8f66ef8 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -170,7 +170,7 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { * Minimal data required to fully reconstruct the execution state. */ -typedef struct TEBCdata { +typedef struct { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ const unsigned char *pc; /* These fields are used on return TO this */ diff --git a/generic/tclIO.c b/generic/tclIO.c index 4e24533..aae66d4 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -24,7 +24,7 @@ * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of nested * ChannelHandlerEventProc invocations. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 005713d..3d04f37 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -15,7 +15,7 @@ * Callback structure for accept callback in a TCP server. */ -typedef struct AcceptCallback { +typedef struct { char *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; @@ -25,7 +25,7 @@ typedef struct AcceptCallback { * It must be per-thread because of std channel limitations. */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ } ThreadSpecificData; diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index cb0282a..4b61538 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -256,7 +256,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -331,7 +331,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ @@ -368,7 +368,7 @@ struct ForwardingResult { * results. */ }; -typedef struct ThreadSpecificData { +typedef struct { /* * Table of all reflected channels owned by this thread. This is the * per-thread version of the per-interpreter map. @@ -774,7 +774,7 @@ TclChanCreateObjCmd( *---------------------------------------------------------------------- */ -typedef struct ReflectEvent { +typedef struct { Tcl_Event header; ReflectedChannel *rcPtr; int events; diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 2b9efb9..99ee2ec 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -87,7 +87,7 @@ static const Tcl_ChannelType tclRTransformType = { * layers upon reading from the channel, plus the functions to manage such. */ -typedef struct _ResultBuffer_ { +typedef struct { unsigned char *buf; /* Reference to the buffer area. */ int allocated; /* Allocated size of the buffer area. */ int used; /* Number of bytes in the buffer, @@ -252,7 +252,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -297,7 +297,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ @@ -328,7 +328,7 @@ struct ForwardingResult { * results. */ }; -typedef struct ThreadSpecificData { +typedef struct { /* * Table of all reflected transformations owned by this thread. */ diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 2d6d898..c0fef56 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -54,7 +54,7 @@ typedef struct FilesystemRecord { * this information each time the corresponding epoch counter changes. */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; int cwdPathEpoch; int filesystemEpoch; @@ -243,7 +243,7 @@ static Tcl_ThreadDataKey fsDataKey; * code. */ -typedef struct FsDivertLoad { +typedef struct { Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 0b0f652..b817b52 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -25,14 +25,14 @@ static const char *tclPreInitScript = NULL; struct Target; /* - * struct Alias: + * Alias: * * Stores information about an alias. Is stored in the slave interpreter and * used by the source command to find the target command in the master when * the source command is invoked. */ -typedef struct Alias { +typedef struct { Tcl_Obj *token; /* Token for the alias command in the slave * interp. This used to be the command name in * the slave when the alias was first @@ -73,7 +73,7 @@ typedef struct Alias { * slave interpreter, e.g. what aliases are defined in it. */ -typedef struct Slave { +typedef struct { Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ Tcl_HashEntry *slaveEntryPtr; /* Hash entry in masters slave table for this @@ -84,7 +84,7 @@ typedef struct Slave { Tcl_Interp *slaveInterp; /* The slave interpreter. */ Tcl_Command interpCmd; /* Interpreter object command. */ Tcl_HashTable aliasTable; /* Table which maps from names of commands in - * slave interpreter to struct Alias defined + * slave interpreter to Alias defined * below. */ } Slave; @@ -127,7 +127,7 @@ typedef struct Target { * only load safe extensions. */ -typedef struct Master { +typedef struct { Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps * from command names to Slave records. */ Target *targetsPtr; /* The head of a doubly-linked list of all the @@ -144,7 +144,7 @@ typedef struct Master { * on a per-interp basis. */ -typedef struct InterpInfo { +typedef struct { Master master; /* Keeps track of all interps for which this * interp is the Master. */ Slave slave; /* Information necessary for this interp to @@ -158,7 +158,7 @@ typedef struct InterpInfo { * likely to work properly on 64-bit architectures. */ -typedef struct ScriptLimitCallback { +typedef struct { Tcl_Interp *interp; /* The interpreter in which to execute the * callback. */ Tcl_Obj *scriptObj; /* The script to execute to perform the @@ -171,7 +171,7 @@ typedef struct ScriptLimitCallback { * table. */ } ScriptLimitCallback; -typedef struct ScriptLimitCallbackKey { +typedef struct { Tcl_Interp *interp; /* The interpreter that the limit callback was * attached to. This is not the interpreter * that the callback runs in! */ diff --git a/generic/tclLink.c b/generic/tclLink.c index a3b42bd..b5e540b 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -21,7 +21,7 @@ * variable. */ -typedef struct Link { +typedef struct { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ Tcl_Obj *varName; /* Name of variable (must be global). This is * needed during trace callbacks, since the diff --git a/generic/tclMain.c b/generic/tclMain.c index 14139ec..a2db09d 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -109,7 +109,7 @@ typedef enum { PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; -typedef struct InteractiveState { +typedef struct { Tcl_Channel input; /* The standard input channel from which lines * are read. */ int tty; /* Non-zero means standard input is a diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 3c93400..16d053e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -31,7 +31,7 @@ * limited to a single interpreter. */ -typedef struct ThreadSpecificData { +typedef struct { long numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a * unique id for each namespace. Cannot be @@ -52,7 +52,7 @@ static Tcl_ThreadDataKey dataKey; * with some information that is used to check the cached pointer's validity. */ -typedef struct ResolvedNsName { +typedef struct { Namespace *nsPtr; /* A cached pointer to the Namespace that the * name resolved to. */ Namespace *refNsPtr; /* Points to the namespace context in which diff --git a/generic/tclObj.c b/generic/tclObj.c index 74cb29e..03141e4 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -58,7 +58,7 @@ char *tclEmptyStringRep = &tclEmptyString; * for sanity checking purposes. */ -typedef struct ObjData { +typedef struct { Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */ const char *file; /* The name of the source file calling this * function; used for debugging. */ diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index db07c0e..14c61a9 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -71,7 +71,7 @@ static const Tcl_ObjType tclFsPathType = { * */ -typedef struct FsPath { +typedef struct { Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. If this * is NULL, then this is a pure normalized, * absolute path object, in which the parent diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 9b6e942..2860949 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -39,7 +39,7 @@ typedef struct PkgAvail { * "Tk" (no version number). */ -typedef struct Package { +typedef struct { char *version; /* Version that has been supplied in this * interpreter via "package provide" * (malloc'ed). NULL means the package doesn't diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index 0bd8f93..62c8de4 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -53,7 +53,7 @@ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ * objects that we don't want to live any longer than necessary. */ -typedef struct HandleStruct { +typedef struct { void *ptr; /* Pointer to the memory block being tracked. * This field will become NULL when the memory * block is deleted. This field must be the diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 6c1dc08..4977934 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -64,7 +64,7 @@ #define NUM_REGEXPS 30 -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular * expression patterns. NULL means that this diff --git a/generic/tclResult.c b/generic/tclResult.c index 9707f20..a441d3d 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -35,7 +35,7 @@ static void SetupAppendBuffer(Interp *iPtr, int newSpace); * then back up to the result or the error that was previously in progress. */ -typedef struct InterpState { +typedef struct { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ diff --git a/generic/tclScan.c b/generic/tclScan.c index ef7eedf..c54395d 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -28,7 +28,7 @@ * character set. */ -typedef struct CharSet { +typedef struct { int exclude; /* 1 if this is an exclusion set. */ int nchars; Tcl_UniChar *chars; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 04cf4ee..64c661b 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -104,7 +104,7 @@ const Tcl_ObjType tclStringType = { * tcl.h, but do not do that unless you are sure what you're doing! */ -typedef struct String { +typedef struct { int numChars; /* The number of chars in the string. -1 means * this value has not been calculated. >= 0 * means that there is a valid Unicode rep, or diff --git a/generic/tclTest.c b/generic/tclTest.c index 5dc95f9..050f065 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -98,7 +98,7 @@ static Tcl_Trace cmdTrace; * TestdelCmd: */ -typedef struct DelCmd { +typedef struct { Tcl_Interp *interp; /* Interpreter in which command exists. */ char *deleteCmd; /* Script to execute when command is deleted. * Malloc'ed. */ @@ -109,7 +109,7 @@ typedef struct DelCmd { * command. */ -typedef struct TclEncoding { +typedef struct { Tcl_Interp *interp; char *toUtfCmd; char *fromUtfCmd; @@ -132,7 +132,7 @@ static int exitMainLoop = 0; * Event structure used in testing the event queue management procedures. */ -typedef struct TestEvent { +typedef struct { Tcl_Event header; /* Header common to all events */ Tcl_Interp *interp; /* Interpreter that will handle the event */ Tcl_Obj *command; /* Command to evaluate when the event occurs */ diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 7494beb..c86eb9f 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -47,7 +47,7 @@ static int TestobjCmd(ClientData dummy, Tcl_Interp *interp, static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -typedef struct TestString { +typedef struct { int numChars; int allocated; int maxChars; diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index a3f89f6..3324b98 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -34,7 +34,7 @@ static const char procCommand[] = "proc"; * procs */ -typedef struct CmdTable { +typedef struct { const char *cmdName; /* command name */ Tcl_ObjCmdProc *proc; /* command proc */ int exportIt; /* if 1, export the command */ diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index e4261d6..e57988b 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -82,7 +82,7 @@ typedef union Block { * and statistics information. */ -typedef struct Bucket { +typedef struct { Block *firstPtr; /* First block available */ long numFree; /* Number of blocks available */ diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index f24e334..36bf0a5 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -47,7 +47,7 @@ static struct TSDMaster { * The type of the data held per thread in a system TSD. */ -typedef struct TSDTable { +typedef struct { ClientData *tablePtr; /* The table of Tcl TSDs. */ sig_atomic_t allocated; /* The size of the table in the current * thread. */ diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 22b5995..aa9aaef 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -61,7 +61,7 @@ static ThreadSpecificData *threadList = NULL; * "thread create" Tcl command or the ThreadCreate() C function. */ -typedef struct ThreadCtrl { +typedef struct { const char *script; /* The Tcl command this thread should * execute */ int flags; /* Initial value of the "flags" field in the diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 6b17825..735c54a 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -91,7 +91,7 @@ typedef struct IdleHandler { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ int lastTimerId; /* Timer identifier of most recently created * timer. */ diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 519f201..2dfd893 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -143,7 +143,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1, * trace procs */ -typedef struct StringTraceData { +typedef struct { ClientData clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 9ee37f1..023e082 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -99,7 +99,7 @@ * This structure describes per-instance state of a file based channel. */ -typedef struct FileState { +typedef struct { Tcl_Channel channel; /* Channel associated with this file. */ int fd; /* File handle. */ int validMask; /* OR'ed combination of TCL_READABLE, @@ -126,7 +126,7 @@ typedef struct TtyState { * a platform-independant manner. */ -typedef struct TtyAttrs { +typedef struct { int baud; int parity; int data; diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index e201018..5cb35d2 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -49,7 +49,7 @@ #ifdef TCL_THREADS -typedef struct ThreadSpecificData { +typedef struct { struct passwd pwd; #if defined(HAVE_GETPWNAM_R_5) || defined(HAVE_GETPWUID_R_5) #define NEED_PW_CLEANER 1 diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index f07b123..39be160 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -42,12 +42,12 @@ static const char *const platforms[NUMPLATFORMS] = { }; #define NUMPROCESSORS 11 -static const char *const processors[NUMPROCESSORS] = { +static const char *const processors[NUMPROCESSORS] = { "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" }; -typedef struct _SYSTEM_INFO { +typedef struct { union { DWORD dwOemId; struct { @@ -66,7 +66,7 @@ typedef struct _SYSTEM_INFO { int wProcessorRevision; } SYSTEM_INFO; -typedef struct _OSVERSIONINFOA { +typedef struct { DWORD dwOSVersionInfoSize; DWORD dwMajorVersion; DWORD dwMinorVersion; @@ -112,7 +112,7 @@ static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH; * first list checked for a mapping from env encoding to Tcl encoding name. */ -typedef struct LocaleTable { +typedef struct { const char *lang; const char *encoding; } LocaleTable; diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index b87af1b..5c03b79 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -39,7 +39,7 @@ typedef struct FileHandler { * handlers are ready to fire. */ -typedef struct FileHandlerEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ int fd; /* File descriptor that is ready. Used to find @@ -54,7 +54,7 @@ typedef struct FileHandlerEvent { * writable, and exception conditions. */ -typedef struct SelectMasks { +typedef struct { fd_set readable; fd_set writable; fd_set exception; diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 654c9d8..e2a534e 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -30,7 +30,7 @@ * This structure describes per-instance state of a pipe based channel. */ -typedef struct PipeState { +typedef struct { Tcl_Channel channel; /* Channel associated with this file. */ TclFile inFile; /* Output from pipe. */ TclFile outFile; /* Input to pipe. */ diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 46fc972..8b3338a 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -37,7 +37,7 @@ * exercised by the "testfilehandler" command. */ -typedef struct Pipe { +typedef struct { TclFile readFile; /* File handle for reading from the pipe. NULL * means pipe doesn't exist yet. */ TclFile writeFile; /* File handle for writing from the pipe. */ diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 789dbb6..9a1efbe 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -15,7 +15,7 @@ #ifdef TCL_THREADS -typedef struct ThreadSpecificData { +typedef struct { char nabuf[16]; } ThreadSpecificData; @@ -683,7 +683,7 @@ TclpInetNtoa( static volatile int initialized = 0; static pthread_key_t key; -typedef struct allocMutex { +typedef struct { Tcl_Mutex tlock; pthread_mutex_t plock; } allocMutex; @@ -691,10 +691,10 @@ typedef struct allocMutex { Tcl_Mutex * TclpNewAllocMutex(void) { - struct allocMutex *lockPtr; + allocMutex *lockPtr; register pthread_mutex_t *plockPtr; - lockPtr = malloc(sizeof(struct allocMutex)); + lockPtr = malloc(sizeof(allocMutex)); if (lockPtr == NULL) { Tcl_Panic("could not allocate lock"); } diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index c7921fe..9497502 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -26,7 +26,7 @@ */ static Tcl_ThreadDataKey tmKey; -typedef struct ThreadSpecificData { +typedef struct { struct tm gmtime_buf; struct tm localtime_buf; } ThreadSpecificData; diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 52b9e32..e8f46ef 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -43,7 +43,7 @@ typedef struct FileInfo { * pending on the channel. */ } FileInfo; -typedef struct ThreadSpecificData { +typedef struct { /* * List of all file channels currently open. */ @@ -58,7 +58,7 @@ static Tcl_ThreadDataKey dataKey; * events are generated. */ -typedef struct FileEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ FileInfo *infoPtr; /* Pointer to file info structure. Note that diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 5aab255..094a5e9 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -50,7 +50,7 @@ TCL_DECLARE_MUTEX(consoleMutex) * threads. */ -typedef struct ConsoleThreadInfo { +typedef struct { HANDLE thread; /* Handle to reader or writer thread. */ HANDLE readyEvent; /* Manual-reset event to signal _to_ the main * thread when the worker thread has finished @@ -113,7 +113,7 @@ typedef struct ConsoleInfo { /* Data consumed by reader thread. */ } ConsoleInfo; -typedef struct ThreadSpecificData { +typedef struct{ /* * The following pointer refers to the head of the list of consoles that * are being watched for file events. @@ -129,7 +129,7 @@ static Tcl_ThreadDataKey dataKey; * console events are generated. */ -typedef struct ConsoleEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ ConsoleInfo *infoPtr; /* Pointer to console info structure. Note diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 23b3a8e..bf8cc86 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -68,7 +68,7 @@ typedef struct Conversation { Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */ } Conversation; -typedef struct DdeEnumServices { +typedef struct { Tcl_Interp *interp; int result; ATOM service; @@ -76,7 +76,7 @@ typedef struct DdeEnumServices { HWND hwnd; } DdeEnumServices; -typedef struct ThreadSpecificData { +typedef struct { Conversation *currentConversations; /* A list of conversations currently being * processed. */ @@ -113,7 +113,7 @@ TCL_DECLARE_MUTEX(ddeMutex) static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); -static int DdeCreateClient(struct DdeEnumServices *es); +static int DdeCreateClient(DdeEnumServices *es); static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); static void DdeExitProc(ClientData clientData); @@ -1038,7 +1038,7 @@ MakeDdeConnection( static int DdeCreateClient( - struct DdeEnumServices *es) + DdeEnumServices *es) { WNDCLASSEX wc; static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); @@ -1048,7 +1048,7 @@ DdeCreateClient( wc.cbSize = sizeof(wc); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; - wc.cbWndExtra = sizeof(struct DdeEnumServices *); + wc.cbWndExtra = sizeof(DdeEnumServices *); /* * Register and create the callback window. @@ -1070,8 +1070,8 @@ DdeClientWindowProc( switch (uMsg) { case WM_CREATE: { LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; - struct DdeEnumServices *es = - (struct DdeEnumServices *) lpcs->lpCreateParams; + DdeEnumServices *es = + (DdeEnumServices *) lpcs->lpCreateParams; #ifdef _WIN64 SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es); @@ -1096,14 +1096,14 @@ DdeServicesOnAck( HWND hwndRemote = (HWND)wParam; ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); - struct DdeEnumServices *es; + DdeEnumServices *es; TCHAR sz[255]; Tcl_DString dString; #ifdef _WIN64 - es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); + es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); #else - es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); + es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); #endif if ((es->service == (ATOM)0 || es->service == service) @@ -1154,7 +1154,7 @@ DdeEnumWindowsCallback( LPARAM lParam) { DWORD_PTR dwResult = 0; - struct DdeEnumServices *es = (struct DdeEnumServices *) lParam; + DdeEnumServices *es = (DdeEnumServices *) lParam; SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, @@ -1168,7 +1168,7 @@ DdeGetServicesList( const TCHAR *serviceName, const TCHAR *topicName) { - struct DdeEnumServices es; + DdeEnumServices es; es.interp = interp; es.result = TCL_OK; diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 4543b02..aaa5878 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -27,7 +27,7 @@ * created for each thread that is using the notifier. */ -typedef struct ThreadSpecificData { +typedef struct { CRITICAL_SECTION crit; /* Monitor for this notifier. */ DWORD thread; /* Identifier for thread associated with this * notifier. */ diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 36ae58a..3309858 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -52,7 +52,7 @@ TCL_DECLARE_MUTEX(pipeMutex) * used in a pipeline. */ -typedef struct WinFile { +typedef struct { int type; /* One of the file types defined above. */ HANDLE handle; /* Open file handle. */ } WinFile; @@ -144,7 +144,7 @@ typedef struct PipeInfo { * synchronized with the readable object. */ } PipeInfo; -typedef struct ThreadSpecificData { +typedef struct { /* * The following pointer refers to the head of the list of pipes that are * being watched for file events. @@ -160,7 +160,7 @@ static Tcl_ThreadDataKey dataKey; * events are generated. */ -typedef struct PipeEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ PipeInfo *infoPtr; /* Pointer to pipe info structure. Note that diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 9e9d1af..4c9a495 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -122,7 +122,7 @@ typedef struct SerialInfo { * [fconfigure -queue] */ } SerialInfo; -typedef struct ThreadSpecificData { +typedef struct { /* * The following pointer refers to the head of the list of serials that * are being watched for file events. @@ -138,7 +138,7 @@ static Tcl_ThreadDataKey dataKey; * events are generated. */ -typedef struct SerialEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ SerialInfo *infoPtr; /* Pointer to serial info structure. Note that diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 9f7caee..62b2f7f 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -163,7 +163,7 @@ struct SocketInfo { * socket event occurs. */ -typedef struct SocketEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ SOCKET socket; /* Socket descriptor that is ready. Used to @@ -191,7 +191,7 @@ typedef struct SocketEvent { #define SOCKET_PENDING (1<<3) /* A message has been sent for this * socket */ -typedef struct ThreadSpecificData { +typedef struct { HWND hwnd; /* Handle to window for socket messages. */ HANDLE socketThread; /* Thread handling the window */ Tcl_ThreadId threadId; /* Parent thread. */ diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 102fd40..5d4a754 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -102,7 +102,7 @@ static Tcl_ThreadDataKey dataKey; * the queue. */ -typedef struct WinCondition { +typedef struct { CRITICAL_SECTION condLock; /* Lock to serialize queuing on the * condition. */ struct ThreadSpecificData *firstPtr; /* Queue pointers */ @@ -117,7 +117,7 @@ typedef struct WinCondition { static int once; static DWORD tlsKey; -typedef struct allocMutex { +typedef struct { Tcl_Mutex tlock; CRITICAL_SECTION wlock; } allocMutex; @@ -873,9 +873,9 @@ TclpFinalizeCondition( Tcl_Mutex * TclpNewAllocMutex(void) { - struct allocMutex *lockPtr; + allocMutex *lockPtr; - lockPtr = malloc(sizeof(struct allocMutex)); + lockPtr = malloc(sizeof(allocMutex)); if (lockPtr == NULL) { Tcl_Panic("could not allocate lock"); } diff --git a/win/tclWinTime.c b/win/tclWinTime.c index daa229d..80e51b6 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -35,7 +35,7 @@ static const int leapDays[] = { -1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 }; -typedef struct ThreadSpecificData { +typedef struct { char tzName[64]; /* Time zone name */ struct tm tm; /* time information */ } ThreadSpecificData; @@ -45,7 +45,7 @@ static Tcl_ThreadDataKey dataKey; * Data for managing high-resolution timers. */ -typedef struct TimeInfo { +typedef struct { CRITICAL_SECTION cs; /* Mutex guarding this structure. */ int initialized; /* Flag == 1 if this structure is * initialized. */ -- cgit v0.12 From 4c681f294b0469fff7d65e9c8718ccf2ff128b2c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Aug 2012 08:59:36 +0000 Subject: Remove wrapper macro for ntohs(): unnecessary, because it doesn't require an initialized winsock_2 library --- generic/tclStubInit.c | 7 +------ win/tclWinPort.h | 1 - win/tclWinSock.c | 22 ++-------------------- 3 files changed, 3 insertions(+), 27 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7b73ee3..3be6b45 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -74,6 +74,7 @@ MODULE_SCOPE TclIntPlatStubs tclIntPlatStubs; MODULE_SCOPE TclPlatStubs tclPlatStubs; MODULE_SCOPE TclStubs tclStubs; MODULE_SCOPE TclTomMathStubs tclTomMathStubs; +#define TclWinNToHS ntohs #ifdef __WIN32__ # define TclUnixWaitForFile 0 @@ -112,12 +113,6 @@ void *TclWinGetTclInstance() return hInstance; } -unsigned short -TclWinNToHS(unsigned short ns) -{ - return ntohs(ns); -} - int TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 4f9e8b8..f58014c 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -457,7 +457,6 @@ typedef DWORD_PTR * PDWORD_PTR; #define getservbyname TclWinGetServByName #define getsockopt TclWinGetSockOpt -#define ntohs TclWinNToHS #define setsockopt TclWinSetSockOpt /* This type is not defined in the Windows headers */ #define socklen_t int diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 63f166d..8f2028d 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -65,7 +65,6 @@ #undef getservbyname #undef getsockopt -#undef ntohs #undef setsockopt /* @@ -131,7 +130,7 @@ typedef struct SocketInfo { * socket event occurs. */ -typedef struct SocketEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ SOCKET socket; /* Socket descriptor that is ready. Used to @@ -159,7 +158,7 @@ typedef struct SocketEvent { #define SOCKET_PENDING (1<<3) /* A message has been sent for this * socket */ -typedef struct ThreadSpecificData { +typedef struct { HWND hwnd; /* Handle to window for socket messages. */ HANDLE socketThread; /* Thread handling the window */ Tcl_ThreadId threadId; /* Parent thread. */ @@ -2508,23 +2507,6 @@ TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, return setsockopt(s, level, optname, optval, optlen); } -unsigned short -TclWinNToHS(unsigned short netshort) -{ - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - - if (!SocketsEnabled()) { - return (unsigned short) -1; - } - - return ntohs(netshort); -} - char * TclpInetNtoa(struct in_addr addr) { -- cgit v0.12 From f8238e5ef94bd2f49b2f040a6dfa68294c5d5ba1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Aug 2012 09:01:08 +0000 Subject: ... and don't forget ChangeLog entry --- ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ChangeLog b/ChangeLog index 3dfcc09..d5e6345 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-08-20 Jan Nijtmans + + * win/tclWinPort.h: Remove wrapper macro for ntohs(): unnecessary, + because it doesn't require an initialized winsock_2 library. See: + + * win/tclWinSock.c + * generic/tclStubInit.c + 2012-08-17 Jan Nijtmans * win/nmakehlp.c: Add "-V" option, in order to be able -- cgit v0.12 From 79503b8aa18649d94ee9a98f1386d7f58787a408 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 20 Aug 2012 23:45:25 +0000 Subject: 3559678 Fix bad filename normalization when the last component is the empty string. --- ChangeLog | 5 +++++ generic/tclPathObj.c | 9 +++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index d5e6345..b1c9079 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-20 Don Porter + + * generic/tclPathObj.c: [Bug 3559678] Fix bad filename normalization + when the last component is the empty string. + 2012-08-20 Jan Nijtmans * win/tclWinPort.h: Remove wrapper macro for ntohs(): unnecessary, diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index ac9df3a..c9b3b8e 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1831,7 +1831,7 @@ Tcl_FSGetNormalizedPath( */ Tcl_Obj *dir, *copy; - int cwdLen, pathType; + int tailLen, cwdLen, pathType; pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); @@ -1843,7 +1843,12 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } - copy = AppendPath(dir, fsPathPtr->normPathPtr); + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + if (tailLen) { + copy = AppendPath(dir, fsPathPtr->normPathPtr); + } else { + copy = Tcl_DuplicateObj(dir); + } Tcl_IncrRefCount(dir); Tcl_IncrRefCount(copy); -- cgit v0.12 From b3f490fa84391bd5d1cd9ff82d6235e527a22c28 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Aug 2012 12:07:22 +0000 Subject: [Bug 3496014] Protect Tcl_SetByteArrayObj for invalid values (Backported from Tcl 8.6) --- ChangeLog | 5 +++++ generic/tclBinary.c | 7 ++++++- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index b1c9079..74ff19b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-23 Jan Nijtmans + + * generic/tclBinary.c: [Bug 3496014] (Backport from Tcl 8.6) Protect + Tcl_SetByteArrayObj for invalid values. + 2012-08-20 Don Porter * generic/tclPathObj.c: [Bug 3559678] Fix bad filename normalization diff --git a/generic/tclBinary.c b/generic/tclBinary.c index f321b28..8c95305 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -273,10 +273,15 @@ Tcl_SetByteArrayObj( TclFreeIntRep(objPtr); Tcl_InvalidateStringRep(objPtr); + if (length < 0) { + length = 0; + } byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; - memcpy(byteArrayPtr->bytes, bytes, (size_t) length); + if (length && bytes) { + memcpy(byteArrayPtr->bytes, bytes, (size_t) length); + } objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); -- cgit v0.12 From 1b1df98eb9755670524e036036bb887b86df8079 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Aug 2012 20:06:18 +0000 Subject: small wrapper for TclWinNToHs, for change in calling convention --- generic/tclStubInit.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 3be6b45..6a3207b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -74,7 +74,12 @@ MODULE_SCOPE TclIntPlatStubs tclIntPlatStubs; MODULE_SCOPE TclPlatStubs tclPlatStubs; MODULE_SCOPE TclStubs tclStubs; MODULE_SCOPE TclTomMathStubs tclTomMathStubs; -#define TclWinNToHS ntohs + +#if defined(_WIN32) || defined(__CYGWIN__) +unsigned short TclWinNToHS(unsigned short ns) { + return ntohs(ns); +} +#endif #ifdef __WIN32__ # define TclUnixWaitForFile 0 -- cgit v0.12 From e1f580d44308ba8f846d79d6d51ba1d8fc093712 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Aug 2012 06:29:44 +0000 Subject: make sure that extensions which might still use TclWinNToHS, now use ntohs directly. --- generic/tclIntPlatDecls.h | 5 ++++- generic/tclStubInit.c | 1 + 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 34a23a4..1e68c9c 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -845,7 +845,10 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpLocaltime_unix #undef TclpGmtime_unix -#if !defined(__WIN32__) && !defined(__CYGWIN__) +#if defined(__WIN32__) || defined(__CYGWIN__) +# undef TclWinNToHS +# define TclWinNToHS ntohs +#else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) #endif diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6a3207b..d06e174 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -76,6 +76,7 @@ MODULE_SCOPE TclStubs tclStubs; MODULE_SCOPE TclTomMathStubs tclTomMathStubs; #if defined(_WIN32) || defined(__CYGWIN__) +#undef TclWinNToHS unsigned short TclWinNToHS(unsigned short ns) { return ntohs(ns); } -- cgit v0.12 From b3655e630c7c0ceda257474bb114dcffa2630253 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 Aug 2012 10:07:16 +0000 Subject: [Bug 3561330]: Use the correct full name of March in Ukrainian. --- ChangeLog | 5 +++++ library/msgs/uk.msg | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 74ff19b..b8776c9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-25 Donal K. Fellows + + * library/msgs/uk.msg: [Bug 3561330]: Use the correct full name of + March in Ukrainian. Thanks to Mikhail Teterin for reporting. + 2012-08-23 Jan Nijtmans * generic/tclBinary.c: [Bug 3496014] (Backport from Tcl 8.6) Protect diff --git a/library/msgs/uk.msg b/library/msgs/uk.msg index 3e24f86..7d4c64a 100755 --- a/library/msgs/uk.msg +++ b/library/msgs/uk.msg @@ -33,7 +33,7 @@ namespace eval ::tcl::clock { ::msgcat::mcset uk MONTHS_FULL [list \ "\u0441\u0456\u0447\u043d\u044f"\ "\u043b\u044e\u0442\u043e\u0433\u043e"\ - "\u0431\u0435\u0440\u0435\u0436\u043d\u044f"\ + "\u0431\u0435\u0440\u0435\u0437\u043d\u044f"\ "\u043a\u0432\u0456\u0442\u043d\u044f"\ "\u0442\u0440\u0430\u0432\u043d\u044f"\ "\u0447\u0435\u0440\u0432\u043d\u044f"\ -- cgit v0.12 From 7122c1dbde26a673edafca375ee090db34f896c9 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 Aug 2012 16:39:25 +0000 Subject: minor: tidy up formatting --- ChangeLog | 137 ++++++++++++++++++++++++++++++++------------------------------ 1 file changed, 71 insertions(+), 66 deletions(-) diff --git a/ChangeLog b/ChangeLog index b8776c9..18cdf37 100644 --- a/ChangeLog +++ b/ChangeLog @@ -5,12 +5,12 @@ 2012-08-23 Jan Nijtmans - * generic/tclBinary.c: [Bug 3496014] (Backport from Tcl 8.6) Protect + * generic/tclBinary.c: [Bug 3496014]: (Backport from Tcl 8.6) Protect Tcl_SetByteArrayObj for invalid values. 2012-08-20 Don Porter - * generic/tclPathObj.c: [Bug 3559678] Fix bad filename normalization + * generic/tclPathObj.c: [Bug 3559678]: Fix bad filename normalization when the last component is the empty string. 2012-08-20 Jan Nijtmans @@ -34,8 +34,8 @@ 2010-08-13 Stuart Cassoff - * unix/tclUnixCompat.c: [Bug 3555454] Rearrange a bit - to quash 'declared but never defined' compiler warnings. + * unix/tclUnixCompat.c: [Bug 3555454]: Rearrange a bit to quash + 'declared but never defined' compiler warnings. 2012-08-08 Jan Nijtmans @@ -44,8 +44,8 @@ 2012-08-07 Don Porter - * generic/tclIOUtil.c: [Bug 3554250] Overlooked one field of - cleanup in the thread exit handler for the filesystem subsystem. + * generic/tclIOUtil.c: [Bug 3554250]: Overlooked one field of cleanup + in the thread exit handler for the filesystem subsystem. 2012-07-31 Jan Nijtmans @@ -54,8 +54,8 @@ 2012-07-28 Jan Nijtmans - * tests/clock.test: [Bug 3549770] Multiple test failures running tcltest - * tests/registry.test: outside build tree + * tests/clock.test: [Bug 3549770]: Multiple test failures running + * tests/registry.test: tcltest outside build tree * tests/winDde.test: 2012-07-27 Jan Nijtmans @@ -112,7 +112,8 @@ 2012-07-10 Jan Nijtmans - * unix/tclUnixNotfy.c: [Bug 3541646] Don't panic on triggerPipe overrun + * unix/tclUnixNotfy.c: [Bug 3541646]: Don't panic on triggerPipe + overrun. 2012-07-10 Donal K. Fellows @@ -123,7 +124,7 @@ 2012-07-05 Don Porter - * unix/tclUnixPipe.c: [Bug 1189293] Make "<<" binary safe. + * unix/tclUnixPipe.c: [Bug 1189293]: Make "<<" binary safe. * win/tclWinPipe.c: 2012-06-29 Jan Nijtmans @@ -132,10 +133,10 @@ 2012-06-29 Harald Oehlmann - * library/msgcat/msgcat.tcl: [Bug 3536888] Locale guessing of msgcat - * library/msgcat/pkgIndex.tcl: fails on (some) Windows 7. Bump to 1.4.5 - * unix/Makefile.in - * win/Makefile.in + * library/msgcat/msgcat.tcl: [Bug 3536888]: Locale guessing of + * library/msgcat/pkgIndex.tcl: msgcat fails on (some) Windows 7. Bump + * unix/Makefile.in: to 1.4.5 + * win/Makefile.in: 2012-06-29 Donal K. Fellows @@ -147,7 +148,7 @@ 2012-06-25 Don Porter - * generic/tclFileSystem.h: [Bug 3024359] Make sure that the + * generic/tclFileSystem.h: [Bug 3024359]: Make sure that the * generic/tclIOUtil.c: per-thread cache of the list of file systems * generic/tclPathObj.c: currently registered is only updated at times when no active loops are traversing it. Also reduce the amount of @@ -176,10 +177,10 @@ 2012-06-11 Don Porter - * generic/tclBasic.c: [Bug 3532959] Make sure the lifetime management - * generic/tclProc.c: of entries in the linePBodyPtr hash table can - * tests/proc.test: tolerate either order of teardown, interp first, - or Proc first. + * generic/tclBasic.c: [Bug 3532959]: Make sure the lifetime + * generic/tclProc.c: management of entries in the linePBodyPtr + * tests/proc.test: hash table can tolerate either order of + teardown, interp first, or Proc first. 2012-06-08 Don Porter @@ -187,7 +188,7 @@ * unix/tclUnixPort.h: Thanks Joe English. * unix/configure: autoconf 2.13 - * unix/tclUnixPort.h: [Bug 3530533] Centralize #include + * unix/tclUnixPort.h: [Bug 3530533]: Centralize #include * unix/tclUnixThrd.c: in the tclUnixPort.h header so that old unix systems that need inclusion in all compilation units are supported. @@ -214,7 +215,7 @@ 2012-05-25 Jan Nijtmans - * win/tclWinDde.c: [Bug 473946] special characters not correctly + * win/tclWinDde.c: [Bug 473946]: special characters not correctly * win/Makefile.in: sent, now for XTYP_EXECUTE as well as XTYP_REQUEST. Fix "make genstubs" when cross-compiling on UNIX @@ -271,7 +272,7 @@ 2012-05-10 Jan Nijtmans - * win/tclWinDde.c: [Bug 473946] special characters not + * win/tclWinDde.c: [Bug 473946]: Special characters not * library/dde/pkgIndex.tcl: correctly sent. Bump to 1.3.3 2012-05-02 Jan Nijtmans @@ -305,10 +306,10 @@ 2012-04-24 Jan Nijtmans - * generic/tclInt.decls: [Bug 3508771] load tclreg.dll in cygwin - * generic/tclIntPlatDecls.h: tclsh Implement TclWinGetSockOpt, - * generic/tclStubInit.c: TclWinGetServByName and TclWinCPUID - * generic/tclUnixCompat.c: for Cygwin. + * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in + * generic/tclIntPlatDecls.h: cygwin tclsh. Implement + * generic/tclStubInit.c: TclWinGetSockOpt, TclWinGetServByName + * generic/tclUnixCompat.c: and TclWinCPUID for Cygwin. * unix/configure.in: * unix/configure: * unix/tclUnixCompat.c: @@ -330,7 +331,7 @@ 2012-04-11 Jan Nijtmans - * win/tclWinInit.c: [Bug 3448512] [clock scan 1958-01-01] fails + * win/tclWinInit.c: [Bug 3448512]: [clock scan 1958-01-01] fails * win/tcl.m4: in debug compilation. * win/configure: * unix/tcl.m4: Use NDEBUG consistantly meaning: no debugging. @@ -338,7 +339,7 @@ 2012-04-04 Jan Nijtmans - * win/tclWinSock.c: [Bug 510001] TclSockMinimumBuffers needs + * win/tclWinSock.c: [Bug 510001]: TclSockMinimumBuffers needs * generic/tclIOSock.c: platform implementation. * generic/tclInt.decls: * generic/tclIntDecls.h: @@ -353,15 +354,16 @@ 2012-03-30 Jan Nijtmans - * generic/tclInt.decls: [Bug 3508771] load tclreg.dll in cygwin - * generic/tclIntPlatDecls.h: tclsh. Implement TclWinGetTclInstance, - * generic/tclStubInit.c: TclpGetTZName, and various more - win32-specific internal functions for Cygwin, so win32 extensions - using those can be loaded in the cygwin version of tclsh. + * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in + * generic/tclIntPlatDecls.h: cygwin tclsh. Implement + * generic/tclStubInit.c: TclWinGetTclInstance, TclpGetTZName, + and various more win32-specific internal functions for Cygwin, so + win32 extensions using those can be loaded in the cygwin version of + tclsh. 2012-03-30 Jan Nijtmans - * unix/tcl.m4: [Bug 3511806] Compiler checks too early + * unix/tcl.m4: [Bug 3511806]: Compiler checks too early * unix/configure.in: This change allows to build the cygwin * unix/tclUnixPort.h: and mingw32 ports of Tcl/Tk to build * win/tcl.m4: out-of-the-box using a native or cross- @@ -370,19 +372,20 @@ 2012-03-27 Jan Nijtmans - * generic/tcl.h: [Bug 3508771] Wrong Tcl_StatBuf used on MinGW - * generic/tclFCmd.c: [Bug 2015723] duplicate inodes from file stat + * generic/tcl.h: [Bug 3508771]: Wrong Tcl_StatBuf used on MinGW + * generic/tclFCmd.c: [Bug 2015723]: duplicate inodes from file stat on windows (but now for cygwin as well) 2012-03-25 Jan Nijtmans - * generic/tclInt.decls: [Bug 3508771] load tclreg.dll in cygwin - * generic/tclIntPlatDecls.h: tclsh. Implement TclWinConvertError, - * generic/tclStubInit.c: TclWinConvertWSAError, and various more - * unix/Makefile.in: win32-specific internal functions for - * unix/tcl.m4: Cygwin, so win32 extensions using those - * unix/configure: can be loaded in the cygwin version - * win/tclWinError.c: of tclsh. + * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in + * generic/tclIntPlatDecls.h: cygwin tclsh. Implement + * generic/tclStubInit.c: TclWinConvertError, + * unix/Makefile.in: TclWinConvertWSAError, and various + * unix/tcl.m4: more win32-specific internal functions + * unix/configure: for Cygwin, so win32 extensions using + * win/tclWinError.c: those can be loaded in the cygwin + version of tclsh. 2012-03-23 Jan Nijtmans @@ -398,12 +401,13 @@ 2012-03-20 Jan Nijtmans - * generic/tcl.decls: [Bug 3508771] load tclreg.dll in cygwin - * generic/tclInt.decls: tclsh. Implement TclWinGetPlatformId, - * generic/tclIntPlatDecls.h: Tcl_WinUtfToTChar, Tcl_WinTCharToUtf - * generic/tclPlatDecls.h: (and a dummy TclWinCPUID) for Cygwin, - * generic/tclStubInit.c: so win32 extensions using those can be - * unix/tclUnixCompat.c: loaded in the cygwin version of tclsh. + * generic/tcl.decls: [Bug 3508771]: load tclreg.dll in + * generic/tclInt.decls: cygwin tclsh. Implement + * generic/tclIntPlatDecls.h: TclWinGetPlatformId,Tcl_WinUtfToTChar, + * generic/tclPlatDecls.h: Tcl_WinTCharToUtf (and a dummy + * generic/tclStubInit.c: TclWinCPUID) for Cygwin, so win32 + * unix/tclUnixCompat.c: extensions using those can be loaded + in the cygwin version of tclsh. 2012-03-19 Venkat Iyer @@ -437,7 +441,7 @@ 2012-03-15 Jan Nijtmans - * generic/tcl.h: [Bug 3288345] Wrong Tcl_StatBuf used on Cygwin + * generic/tcl.h: [Bug 3288345]: Wrong Tcl_StatBuf used on Cygwin * unix/tclUnixFile.c * unix/tclUnixPort.h * win/cat.c: Remove cygwin stuff no longer needed @@ -446,7 +450,7 @@ 2012-03-12 Jan Nijtmans - * win/tclWinFile.c: [Bug 3388350] mingw64 compiler warnings + * win/tclWinFile.c: [Bug 3388350]: mingw64 compiler warnings 2012-03-07 Andreas Kupries @@ -468,7 +472,7 @@ 2012-02-29 Jan Nijtmans - * generic/tclIOUtil.c: [Bug 3466099] BOM in Unicode + * generic/tclIOUtil.c: [Bug 3466099]: BOM in Unicode * generic/tclEncoding.c: * tests/source.test @@ -603,7 +607,7 @@ 2011-12-23 Jan Nijtmans - * generic/tclUtf.c: [Bug 3464428] string is graph \u0120 is wrong + * generic/tclUtf.c: [Bug 3464428]: string is graph \u0120 is wrong * generic/tclUniData.c: * generic/regc_locale.c: * tests/utf.test: @@ -617,7 +621,7 @@ 2011-12-07 Jan Nijtmans - * tools/uniParse.tcl: [Bug 3444754] string tolower \u01c5 is wrong + * tools/uniParse.tcl: [Bug 3444754]: string tolower \u01c5 is wrong * generic/tclUniData.c: * tests/utf.test: @@ -636,7 +640,7 @@ 2011-11-22 Jan Nijtmans - * win/tclWinPort.h: [Bug 3354324] Windows: file mtime + * win/tclWinPort.h: [Bug 3354324]: Windows: file mtime * win/tclWinFile.c: sets wrong time (VS2005+ only) * generic/tclTest.c: @@ -680,15 +684,15 @@ 2011-10-11 Jan Nijtmans - * win/tclWinFile.c: [Bug 2935503] Incorrect mode field + * win/tclWinFile.c: [Bug 2935503]: Incorrect mode field returned by file stat command 2011-10-07 Jan Nijtmans - * generic/tclIORChan.c: Fix gcc warning - (discovered with latest mingw, based on gcc 4.6.1) - * tests/env.test: Fix env.test, when running - under wine 1.3 (partly backported from Tcl 8.6) + * generic/tclIORChan.c: Fix gcc warning (discovered with latest + mingw, based on gcc 4.6.1) + * tests/env.test: Fix env.test running under wine 1.3 (partly + backported from Tcl 8.6) 2011-10-03 Venkat Iyer @@ -723,20 +727,20 @@ 2011-09-13 Don Porter - * generic/tclUtil.c: [Bug 3390638] Workaround broken solaris + * generic/tclUtil.c: [Bug 3390638]: Workaround broken solaris studio cc optimizer. Thanks to Wolfgang S. Kechel. - * generic/tclDTrace.d: [Bug 3405652] Portability workaround for + * generic/tclDTrace.d: [Bug 3405652]: Portability workaround for broken system DTrace support. Thanks to Dagobert Michelson. 2011-09-12 Jan Nijtmans - * win/tclWinPort.h: [Bug 3407070] tclPosixStr.c won't build with + * win/tclWinPort.h: [Bug 3407070]: tclPosixStr.c won't build with EOVERFLOW==E2BIG 2011-09-07 Don Porter - * generic/tclCompExpr.c: [Bug 3401704] Allow function names like + * generic/tclCompExpr.c: [Bug 3401704]: Allow function names like * tests/parseExpr.test: influence(), nanobot(), and 99bottles() that have been parsed as missing operator syntax errors before with the form NUMBER + FUNCTION. @@ -755,7 +759,7 @@ 2011-09-01 Don Porter - * generic/tclStrToD.c: [Bug 3402540] Corrections to TclParseNumber() + * generic/tclStrToD.c: [Bug 3402540]: Corrections to TclParseNumber() * tests/binary.test: to make it reject invalid Nan(Hex) strings. * tests/scan.test: [scan Inf %g] is portable; remove constraint. @@ -933,7 +937,8 @@ 2011-06-13 Don Porter - * generic/tclStrToD.c: [Bug 3315098] Mem leak fix from Gustaf Neumann. + * generic/tclStrToD.c: [Bug 3315098]: Mem leak fix from Gustaf + Neumann. 2011-06-02 Don Porter -- cgit v0.12 From 1365d5dfb2e603dd60110cae31172da00d07a47a Mon Sep 17 00:00:00 2001 From: andreask Date: Mon, 27 Aug 2012 17:12:06 +0000 Subject: Followup to [6325d5dbeac6f91d28d6]. dlerror() may return NULL. Fixed the code which wasn't prepared to deal with that. --- unix/tclLoadDl.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index f8fe6d3..a48aa23 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -176,8 +176,14 @@ FindSymbol( } Tcl_DStringFree(&ds); if (proc == NULL && interp != NULL) { + const char *errorStr = dlerror(); + + if (!errorStr) { + errorStr = "unknown"; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "cannot find symbol \"%s\": %s", symbol, dlerror())); + "cannot find symbol \"%s\": %s", symbol, errorStr)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } -- cgit v0.12 From 108d7b787052c399b19e4a601b7afe09a84a2966 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 27 Aug 2012 17:24:55 +0000 Subject: Commit of Harald Oehlmann's TIP 404 patch without TIP 399 pieces and with some added documentation. No tests for new functionality yet. --- doc/msgcat.n | 28 +++++++++++++++- library/msgcat/msgcat.tcl | 78 +++++++++++++++++++++++++++++++++++++++++++-- library/msgcat/pkgIndex.tcl | 2 +- 3 files changed, 103 insertions(+), 5 deletions(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index 595c85f..d65563a 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -13,7 +13,7 @@ msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.5\fR .sp -\fBpackage require msgcat 1.4.5\fR +\fBpackage require msgcat 1.5.0\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp @@ -29,6 +29,12 @@ msgcat \- Tcl message catalog .sp \fB::msgcat::mcmset \fIlocale src-trans-list\fR .sp +.VS "TIP 404" +\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? +.sp +\fB::msgcat::mcflmset \fIsrc-trans-list\fR +.VE "TIP 404" +.sp \fB::msgcat::mcunknown \fIlocale src-string\fR .BE .SH DESCRIPTION @@ -131,6 +137,26 @@ translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly faster than multiple invocations of \fB::msgcat::mcset\fR. The function returns the number of translations set. .TP +\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? +.VS "TIP 404" +Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the the +current namespace for the locale implied by the name of the message catalog +being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not +specified, \fIsrc-string\fR is used for both. The function returns +\fItranslate-string\fR. +.VE "TIP 404" +.TP +\fB::msgcat::mcflmset \fIsrc-trans-list\fR +.VS "TIP 404" +Sets the translation for multiple source strings in \fIsrc-trans-list\fR in +the current namespace for the locale implied by the name of the message +catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must +have an even number of elements and is in the form {\fIsrc-string +translate-string\fR ?\fIsrc-string translate-string ...\fR?} +\fB::msgcat::mcmset\fR can be significantly faster than multiple invocations +of \fB::msgcat::mcset\fR. The function returns the number of translations set. +.VE "TIP 404" +.TP \fB::msgcat::mcunknown \fIlocale src-string\fR . This routine is called by \fB::msgcat::mc\fR in the case when diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 3377b47..6dd44d2 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -13,11 +13,11 @@ package require Tcl 8.5 # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.4.5 +package provide msgcat 1.5.0 namespace eval msgcat { namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ - mcunknown + mcunknown mcflset mcflmset # Records the current locale as passed to mclocale variable Locale "" @@ -25,6 +25,12 @@ namespace eval msgcat { # Records the list of locales to search variable Loclist {} + # Records the locale of the currently sourced message catalogue file; this + # would be problematic if anyone were to recursively load a message + # catalog for a different locale from inside a catalog, but that's not a + # case that we really need to worry about. + variable FileLocale + # Records the mapping between source strings and translated strings. The # dict key is of the form " ", where locale and # namespace should be themselves dict values and the value is @@ -277,6 +283,7 @@ proc msgcat::mcpreferences {} { # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { + variable FileLocale set x 0 foreach p [mcpreferences] { if { $p eq {} } { @@ -285,7 +292,12 @@ proc msgcat::mcload {langdir} { set langfile [file join $langdir $p.msg] if {[file exists $langfile]} { incr x + set FileLocale [string tolower [file tail [file rootname $langfile]]] + if {"root" eq $FileLocale} { + set FileLocale "" + } uplevel 1 [list ::source -encoding utf-8 $langfile] + unset FileLocale } } return $x @@ -318,6 +330,35 @@ proc msgcat::mcset {locale src {dest ""}} { return $dest } +# msgcat::mcflset -- +# +# Set the translation for a given string in the current file locale. +# +# Arguments: +# src The source string. +# dest (Optional) The translated string. If omitted, +# the source string is used. +# +# Results: +# Returns the new locale. + +proc msgcat::mcflset {src {dest ""}} { + variable FileLocale + variable Msgs + + if {![info exists FileLocale]} { + return -code error \ + "must only be used inside a message catalog loaded with ::msgcat::mcload" + } + if {[llength [info level 0]] == 2} { ;# dest not specified + set dest $src + } + + set ns [uplevel 1 [list ::namespace current]] + dict set Msgs $FileLocale $ns $src $dest + return $dest +} + # msgcat::mcmset -- # # Set the translation for multiple strings in a specified locale. @@ -345,7 +386,38 @@ proc msgcat::mcmset {locale pairs } { dict set Msgs $locale $ns $src $dest } - return $length + return [expr {$length / 2}] +} + +# msgcat::mcflmset -- +# +# Set the translation for multiple strings in the mc file locale. +# +# Arguments: +# pairs One or more src/dest pairs (must be even length) +# +# Results: +# Returns the number of pairs processed + +proc msgcat::mcflmset {pairs} { + variable FileLocale + variable Msgs + + if {![info exists FileLocale]} { + return -code error \ + "must only be used inside a message catalog loaded with ::msgcat::mcload" + } + set length [llength $pairs] + if {$length % 2} { + return -code error "bad translation list:\ + should be \"[lindex [info level 0] 0] locale {src dest ...}\"" + } + + set ns [uplevel 1 [list ::namespace current]] + foreach {src dest} $pairs { + dict set Msgs $FileLocale $ns $src $dest + } + return [expr {$length / 2}] } # msgcat::mcunknown -- diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 60c2d3c..832bf81 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded msgcat 1.4.5 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.5.0 [list source [file join $dir msgcat.tcl]] -- cgit v0.12 From fd818f0e4daea297de5a1c6a14bd210ca7428b45 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Aug 2012 18:46:27 +0000 Subject: Update changes for 8.6b3 --- changes | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/changes b/changes index 1430f8c..a69a544 100644 --- a/changes +++ b/changes @@ -8023,8 +8023,6 @@ like "nano()" instead of parsing as "nan o()" with missing op (duquette,porter) 2012-02-02 (bug fix)[2974459,2879351,1951574,1852572,1661378,1613456] Fix problems where [file *able] would return false results on Win/Samba (porter) -2012-02-02 (update)[3464401] Support Unicode 6.1 (nijtmans) - 2012-02-06 (bug fix)[3484621] bump bytecode epoch on exec traces (kuhn,sofer) 2012-02-15 (bug fix)[3487626] crash compiling [dict for] (fellows) @@ -8105,6 +8103,14 @@ and Tcl_FSMountsChanged(). (porter) 2012-07-25 (bug fix)[3546275] [auto_execok] search match [exec] (danckaert) +2012-07-27 (update)[3464401] Support Unicode 6.2 (nijtmans) + +2012-08-20 (bug fix)[3559678] [file normalize] EIAS failure (phao,dgp) + +2012-08-25 (bug fix)[3561330] Ukranian translation of "March" (teterin) + Many revisions to better support a Cygwin environment (nijtmans) +Dropped support for OS X versions less than 10.4 (Tiger) (fellows) + --- Released 8.6b3, July 30, 2012 --- See ChangeLog for details --- -- cgit v0.12 From 4c3a4ca226ab8a36144f0096e3eb689b67f8d876 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Aug 2012 18:49:11 +0000 Subject: ...and the date too. --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index a69a544..06b2db1 100644 --- a/changes +++ b/changes @@ -8113,4 +8113,4 @@ Many revisions to better support a Cygwin environment (nijtmans) Dropped support for OS X versions less than 10.4 (Tiger) (fellows) ---- Released 8.6b3, July 30, 2012 --- See ChangeLog for details --- +--- Released 8.6b3, September 7, 2012 --- See ChangeLog for details --- -- cgit v0.12 From bdafa7afcb41f8ba37aea8338559c0673dc6688e Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 2 Sep 2012 07:28:02 +0000 Subject: Add package index entry. --- library/http/pkgIndex.tcl | 1 + 1 file changed, 1 insertion(+) diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index d51f8a8..5ce5c37 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,3 @@ if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded http 2.8.4 [list tclPkgSetup $dir http 2.8.4 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded cookiejar 0.1 [list tclPkgSetup $dir cookiejar 0.1 {{cookiejar.tcl source {::http::cookiejar}}}] -- cgit v0.12 From 51e67d70c40f25577a399ae06cfad0484bb58020 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 4 Sep 2012 21:24:43 +0000 Subject: Improving the cookie lookup code to actually handle paths&domains --- library/http/cookiejar.tcl | 85 +++++++++++++++++++++++++++------------------- 1 file changed, 50 insertions(+), 35 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index e6c1e85..4e67f95 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -78,6 +78,7 @@ namespace eval ::http { } method InitDomainList {} { + variable ::http::CookiejarDomainList db eval { CREATE TABLE IF NOT EXISTS forbidden ( domain TEXT PRIMARY KEY); @@ -86,7 +87,8 @@ namespace eval ::http { CREATE TABLE IF NOT EXISTS permitted ( domain TEXT PRIMARY KEY); } - set tok [http::geturl $::http::CookiejarDomainList] + http::Log "Loading domain list from $CookiejarDomainList" + set tok [http::geturl $CookiejarDomainList] try { if {[http::ncode $tok] == 200} { foreach line [split [http::data $tok] \n] { @@ -96,19 +98,19 @@ namespace eval ::http { set line [string range $line 1 end] db eval { INSERT INTO permitted (domain) - VALUES (:line) + VALUES ($line) } } else { if {[string match {\*.*} $line]} { set line [string range $line 2 end] db eval { INSERT INTO forbiddenSuper (domain) - VALUES (:line) + VALUES ($line) } } db eval { INSERT INTO forbidden (domain) - VALUES (:line) + VALUES ($line) } } } @@ -125,32 +127,44 @@ namespace eval ::http { db close } + method GetCookiesForHostAndPath {result host path} { + upvar 1 $result result + db eval { + SELECT key, value FROM cookies + WHERE domain = $host AND path = $path + } cookie { + dict set result $cookie(key) $cookie(value) + } + db eval { + SELECT key, value FROM sessionCookies + WHERE domain = $host AND path = $path + } cookie { + dict set result $cookie(key) $cookie(value) + } + } method getCookies {proto host port path} { upvar 1 state state set result {} - ## TODO: How to handle prefix matches? -# From kbk -#LENGTH(theColumn) <= LENGTH(:queryStr) AND SUBSTR(theColumn, LENGTH(:queryStr)-LENGTH(theColumn)+1) = :queryStr db transaction { - db eval { - SELECT key, value FROM cookies WHERE domain = :host - } cookie { - dict set result $key $value - } - db eval { - SELECT key, value FROM sessionCookies WHERE domain = :host - } cookie { - dict set result $key $value - } - db eval { - SELECT key, value FROM cookies WHERE origin = :host - } cookie { - dict set result $key $value - } - db eval { - SELECT key, value FROM sessionCookies WHERE origin = :host - } cookie { - dict set result $key $value + # Open question: how to move these manipulations into the + # database engine (if that's where they *should* be) + # Suggestion from kbk + #LENGTH(theColumn) <= LENGTH(:queryStr) AND SUBSTR(theColumn, LENGTH(:queryStr) LENGTH(theColumn)+1) = :queryStr + set pathbits [split [string trimleft $path "/"] "/"] + set hostbits [split $host "."] + if {[regexp {[^0-9.]} $host]} { + for {set i [llength $hostbits]} {[incr i -1] >= 0} {} { + set domain [join [lrange $hostbits $i end] "."] + for {set j -1} {$j < [llength $pathbits]} {incr j} { + set p /[join [lrange $pathbits 0 $j] "/"] + my GetCookiesForHostAndPath result $domain $p + } + } + } else { + for {set j -1} {$j < [llength $pathbits]} {incr j} { + set p /[join [lrange $pathbits 0 $j] "/"] + my GetCookiesForHostAndPath result $host $p + } } } return $result @@ -162,15 +176,16 @@ namespace eval ::http { } set domain [dict get $options domain] db eval { - SELECT domain FROM permitted WHERE domain == :domain + SELECT domain FROM permitted WHERE domain == $domain } x {return 0} db eval { - SELECT domain FROM forbidden WHERE domain == :domain - } x {return 1} - if {![regexp {^[^.]+\.(.+)$} $domain -> super]} {return 1} - db eval { - SELECT domain FROM forbiddenSuper WHERE domain == :domain + SELECT domain FROM forbidden WHERE domain == $domain } x {return 1} + if {[regexp {^[^.]+\.(.+)$} $domain -> super]} { + db eval { + SELECT domain FROM forbiddenSuper WHERE domain == $super + } x {return 1} + } return 0 } @@ -188,16 +203,16 @@ namespace eval ::http { db eval { INSERT OR REPLACE sessionCookies ( origin, domain, key, value) - VALUES (:origin, :domain, :key, :value) + VALUES ($origin, $domain, $key, $value) } } elseif {$expires < $now} { db eval { DELETE FROM cookies - WHERE domain = :domain AND key = :name AND path = :path + WHERE domain = $domain AND key = $name AND path = $path } db eval { DELETE FROM sessionCookies - WHERE domain = :domain AND key = :name AND path = :path + WHERE domain = $domain AND key = $name AND path = $path } } else { ### FIXME -- cgit v0.12 From 5c94189d521507337dc7831ceae34212fadf771b Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Sep 2012 09:37:10 +0000 Subject: Minor clarification of description; all traces use a command prefix for their callbacks. --- doc/trace.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/trace.n b/doc/trace.n index 9d40123..c928856 100644 --- a/doc/trace.n +++ b/doc/trace.n @@ -138,7 +138,7 @@ error will occur. .PP For \fBleave\fR and \fBleavestep\fR operations: .CS -\fIcommand command-string code result op\fR +\fIcommandPrefix command-string code result op\fR .CE \fICommand-string\fR gives the complete current command being executed (the traced command for a \fBenter\fR operation, an -- cgit v0.12 From fa56a98ba9b5e567d53181939645c71ccdfc6cfc Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Sep 2012 09:46:03 +0000 Subject: more realistic queries --- library/http/cookiejar.tcl | 92 ++++++++++++++++++++++++++++++---------------- library/http/http.tcl | 3 +- 2 files changed, 63 insertions(+), 32 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 4e67f95..054698f 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -9,13 +9,14 @@ namespace eval ::http { } ::oo::class create ::http::cookiejar { - variable aid + variable aid deletions constructor {{path ""}} { if {$path eq ""} { sqlite3 [namespace current]::db :memory: } else { sqlite3 [namespace current]::db $path } + set deletions 0 ## FIXME ## Model from Safari: # * Creation instant @@ -62,15 +63,21 @@ namespace eval ::http { ON sessionCookies (origin, path, key) } + db eval { + SELECT COUNT(*) AS cookieCount FROM cookies + } + if {$cookieCount} { + http::Log "loaded cookie store from $path with $cookieCount entries" + } + set aid [after 60000 [namespace current]::my PurgeCookies] if {$path ne ""} { db transaction { - db eval { - SELECT count(*) AS present FROM sqlite_master + if {![db exists { + SELECT 1 FROM sqlite_master WHERE type='table' AND name='forbidden' - } - if {!$present} { + }]} then { my InitDomainList } } @@ -149,7 +156,7 @@ namespace eval ::http { # Open question: how to move these manipulations into the # database engine (if that's where they *should* be) # Suggestion from kbk - #LENGTH(theColumn) <= LENGTH(:queryStr) AND SUBSTR(theColumn, LENGTH(:queryStr) LENGTH(theColumn)+1) = :queryStr + #LENGTH(theColumn) <= LENGTH($queryStr) AND SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr set pathbits [split [string trimleft $path "/"] "/"] set hostbits [split $host "."] if {[regexp {[^0-9.]} $host]} { @@ -174,21 +181,37 @@ namespace eval ::http { if {![dict exists $options domain]} { return 0 } - set domain [dict get $options domain] - db eval { - SELECT domain FROM permitted WHERE domain == $domain - } x {return 0} - db eval { - SELECT domain FROM forbidden WHERE domain == $domain - } x {return 1} + dict with options {} + if {$domain ne $origin} { + http::Log "cookie domain varies from origin ($domain, $origin)" + } + if {[db exists { + SELECT 1 FROM permitted WHERE domain = $domain + }]} {return 0} + if {[db exists { + SELECT 1 FROM forbidden WHERE domain = $domain + }]} {return 1} if {[regexp {^[^.]+\.(.+)$} $domain -> super]} { - db eval { - SELECT domain FROM forbiddenSuper WHERE domain == $super - } x {return 1} + if {[db exists { + SELECT 1 FROM forbiddenSuper WHERE domain = $super + }]} {return 1} } return 0 } + method DeleteCookie {domain path key} { + db eval { + DELETE FROM cookies + WHERE domain = $domain AND key = $name AND path = $path + } + incr deletions [db changes] + db eval { + DELETE FROM sessionCookies + WHERE domain = $domain AND key = $name AND path = $path + } + incr deletions [db changes] + http::Log "deleted cookies for $domain, $path, $path" + } method storeCookie {name val options} { upvar 1 state state set now [clock seconds] @@ -201,26 +224,21 @@ namespace eval ::http { if {!$persistent} { ### FIXME db eval { - INSERT OR REPLACE sessionCookies ( - origin, domain, key, value) - VALUES ($origin, $domain, $key, $value) + INSERT OR REPLACE INTO sessionCookies ( + origin, domain, path, key, value) + VALUES ($origin, $domain, $path, $key, $value) } + http::Log "defined session cookie for $domain, $path, $key" } elseif {$expires < $now} { - db eval { - DELETE FROM cookies - WHERE domain = $domain AND key = $name AND path = $path - } - db eval { - DELETE FROM sessionCookies - WHERE domain = $domain AND key = $name AND path = $path - } + my DeleteCookie $domain $path $key } else { ### FIXME db eval { - INSERT OR REPLACE cookies ( - origin, domain, key, value, expiry) - VALUES (:origin, :domain, :key, :value, :expiry) + INSERT OR REPLACE INTO cookies ( + origin, domain, path, key, value, expiry) + VALUES ($origin, $domain, $path, $key, $value, $expires) } + http::Log "defined persistent cookie for $domain, $path, $key expires at [clock format $expires]" } } } @@ -228,7 +246,19 @@ namespace eval ::http { method PurgeCookies {} { set aid [after 60000 [namespace current]::my PurgeCookies] set now [clock seconds] - db eval {DELETE FROM cookies WHERE expiry < :now} + http::Log "purging cookies that expired before [clock format $now]" + db transaction { + db eval { + DELETE FROM cookies WHERE expiry < $now + } + incr deletions [db changes] + if {$deletions > 100} { + set deletions 0 + db eval { + VACUUM + } + } + } ### TODO: Cap the total number of cookies and session cookies, ### purging least frequently used } diff --git a/library/http/http.tcl b/library/http/http.tcl index 4fa39a4..e434a45 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1192,8 +1192,9 @@ proc http::ParseCookie {token value} { # Convert the options into a list before feeding into the cookie store; # ugly, but quite easy. - set realopts {persistent 0 hostonly 1} + set realopts {persistent 0 hostonly 1 path /} dict set realopts origin $state(host) + dict set realopts domain $state(host) foreach opt [split [regsub -all {;\s+} $opts \u0000] \u0000] { switch -glob -nocase -- $opt { Expires=* { -- cgit v0.12 From 8d9808cb4d764dfccb1a35db84a1ad6a58b31f70 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Sep 2012 10:24:05 +0000 Subject: closer to working --- library/http/cookiejar.tcl | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 054698f..bd85b46 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -1,4 +1,5 @@ package require Tcl 8.6 +package require http 2.8.4 package require sqlite3 package provide cookiejar 0.1 @@ -66,7 +67,7 @@ namespace eval ::http { db eval { SELECT COUNT(*) AS cookieCount FROM cookies } - if {$cookieCount} { + if {[info exist cookieCount] && $cookieCount} { http::Log "loaded cookie store from $path with $cookieCount entries" } @@ -134,8 +135,8 @@ namespace eval ::http { db close } - method GetCookiesForHostAndPath {result host path} { - upvar 1 $result result + method GetCookiesForHostAndPath {*result host path} { + upvar 1 ${*result} result db eval { SELECT key, value FROM cookies WHERE domain = $host AND path = $path -- cgit v0.12 From a23ee46c675547eb49015e946884b841c71d8331 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 6 Sep 2012 09:49:52 +0000 Subject: improve logging, correct 'secure' property handling, correct domain handling, simplify http<->cookiejar interface --- library/http/cookiejar.tcl | 267 +++++++++++++++++++++++++++------------------ library/http/http.tcl | 14 ++- 2 files changed, 171 insertions(+), 110 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index bd85b46..30720f8 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -1,92 +1,96 @@ -package require Tcl 8.6 -package require http 2.8.4 +package require Tcl 8.5 +package require TclOO +package require http 2.7;#2.8.4 package require sqlite3 -package provide cookiejar 0.1 namespace eval ::http { - # TODO is this the _right_ list of domains to use? - variable CookiejarDomainList \ + # TODO: is this the _right_ list of domains to use? + variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 + variable cookiejar_version 0.1 + variable cookiejar_loglevel info } ::oo::class create ::http::cookiejar { + self { + method log {origin level msg} { + upvar 0 ::http::cookiejar_loglevel loglevel + set map {debug 0 info 1 warn 2 error 3} + if {[string map $map $level] >= [string map $map $loglevel]} { + ::http::Log [string toupper $level]:cookiejar($origin):${msg} + } + } + method loglevel {level} { + upvar 0 ::http::cookiejar_loglevel loglevel + if {$level in {debug info warn error}} { + set loglevel $level + } else { + return -code error "unknown log level \"$level\": must be debug, info, warn, or error" + } + } + } + variable aid deletions constructor {{path ""}} { if {$path eq ""} { sqlite3 [namespace current]::db :memory: } else { sqlite3 [namespace current]::db $path + db timeout 500 } + proc log {level msg} "::http::cookiejar log [list [self]] \$level \$msg" set deletions 0 - ## FIXME - ## Model from Safari: - # * Creation instant - # * Domain - # * Expiration instant - # * Name - # * Path - # * Value - ## Model from Firefox: - # CREATE TABLE moz_cookies ( - # id INTEGER PRIMARY KEY, - # name TEXT, - # value TEXT, - # host TEXT, - # path TEXT, - # expiry INTEGER, - # lastAccessed INTEGER, - # isSecure INTEGER, - # isHttpOnly INTEGER, - # baseDomain TEXT, - # creationTime INTEGER) - # CREATE INDEX moz_basedomain ON moz_cookies (baseDomain) - # CREATE UNIQUE INDEX moz_uniqueid ON moz_cookies (name, host, path) db eval { CREATE TABLE IF NOT EXISTS cookies ( id INTEGER PRIMARY KEY, - origin TEXT NOT NULL COLLATE NOCASE, + secure INTEGER NOT NULL, + domain TEXT NOT NULL COLLATE NOCASE, path TEXT NOT NULL, - domain TEXT COLLATE NOCASE, key TEXT NOT NULL, value TEXT NOT NULL, + originonly INTEGER NOT NULL, expiry INTEGER NOT NULL); CREATE UNIQUE INDEX IF NOT EXISTS cookieUnique - ON cookies (origin, path, key) + ON cookies (secure, domain, path, key) } db eval { - CREATE TEMP TABLE IF NOT EXISTS sessionCookies ( - origin TEXT NOT NULL COLLATE NOCASE, + CREATE TEMP TABLE sessionCookies ( + id INTEGER PRIMARY KEY, + secure INTEGER NOT NULL, + domain TEXT NOT NULL COLLATE NOCASE, path TEXT NOT NULL, - domain TEXT COLLATE NOCASE, key TEXT NOT NULL, + originonly INTEGER NOT NULL, value TEXT NOT NULL); - CREATE UNIQUE INDEX IF NOT EXISTS sessionUnique - ON sessionCookies (origin, path, key) + CREATE UNIQUE INDEX sessionUnique + ON sessionCookies (secure, domain, path, key) } db eval { SELECT COUNT(*) AS cookieCount FROM cookies } if {[info exist cookieCount] && $cookieCount} { - http::Log "loaded cookie store from $path with $cookieCount entries" + log info "loaded cookie store from $path with $cookieCount entries" } set aid [after 60000 [namespace current]::my PurgeCookies] + # TODO: domain list refresh policy if {$path ne ""} { - db transaction { - if {![db exists { - SELECT 1 FROM sqlite_master - WHERE type='table' AND name='forbidden' - }]} then { - my InitDomainList - } + if {![db exists { + SELECT 1 FROM sqlite_master + WHERE type='table' AND name='forbidden' + }] && ![db exists { + SELECT 1 FROM forbidden + }]} then { + my InitDomainList } } } - + method InitDomainList {} { - variable ::http::CookiejarDomainList + # TODO: Handle IDNs (but Tcl overall gets that wrong at the moment...) + variable ::http::cookiejar_domainlist db eval { CREATE TABLE IF NOT EXISTS forbidden ( domain TEXT PRIMARY KEY); @@ -95,35 +99,37 @@ namespace eval ::http { CREATE TABLE IF NOT EXISTS permitted ( domain TEXT PRIMARY KEY); } - http::Log "Loading domain list from $CookiejarDomainList" - set tok [http::geturl $CookiejarDomainList] + log debug "loading domain list from $cookiejar_domainlist" + set tok [http::geturl $cookiejar_domainlist] try { if {[http::ncode $tok] == 200} { - foreach line [split [http::data $tok] \n] { - if {[string trim $line] eq ""} continue - if {[string match //* $line]} continue - if {[string match !* $line]} { - set line [string range $line 1 end] - db eval { - INSERT INTO permitted (domain) - VALUES ($line) - } - } else { - if {[string match {\*.*} $line]} { - set line [string range $line 2 end] + db transaction { + foreach line [split [http::data $tok] \n] { + if {[string trim $line] eq ""} continue + if {[string match //* $line]} continue + if {[string match !* $line]} { + set line [string range $line 1 end] db eval { - INSERT INTO forbiddenSuper (domain) + INSERT INTO permitted (domain) + VALUES ($line) + } + } else { + if {[string match {\*.*} $line]} { + set line [string range $line 2 end] + db eval { + INSERT INTO forbiddenSuper (domain) VALUES ($line) + } } - } - db eval { - INSERT INTO forbidden (domain) + db eval { + INSERT INTO forbidden (domain) VALUES ($line) + } } } } } else { - http::Log "Warning: failed to fetch list of forbidden cookie domains" + log error "failed to fetch list of forbidden cookie domains from $cookiejar_domainlist" } } finally { http::cleanup $tok @@ -135,43 +141,71 @@ namespace eval ::http { db close } - method GetCookiesForHostAndPath {*result host path} { + method RenderLocation {secure domain path {key ""}} { + if {$key eq ""} { + format "%s://%s%s" [expr {$secure?"https":"http"}] $domain $path + } else { + format "%s://%s%s?%s" \ + [expr {$secure?"https":"http"}] $domain $path $key + } + } + + method GetCookiesForHostAndPath {*result secure host path fullhost} { upvar 1 ${*result} result + log debug "check for cookies for [my RenderLocation $secure $host $path]" db eval { SELECT key, value FROM cookies - WHERE domain = $host AND path = $path + WHERE secure <= $secure AND domain = $host AND path = $path + AND (NOT originonly OR domain = $fullhost) } cookie { - dict set result $cookie(key) $cookie(value) + lappend result $cookie(key) $cookie(value) } db eval { SELECT key, value FROM sessionCookies - WHERE domain = $host AND path = $path + WHERE secure <= $secure AND domain = $host AND path = $path + AND (NOT originonly OR domain = $fullhost) } cookie { - dict set result $cookie(key) $cookie(value) + lappend result $cookie(key) $cookie(value) + } + } + + method SplitDomain domain { + set pieces [split $domain "."] + for {set i [llength $pieces]} {[incr i -1] >= 0} {} { + lappend result [join [lrange $pieces $i end] "."] } + return $result } - method getCookies {proto host port path} { + method SplitPath path { + set pieces [split [string trimleft $path "/"] "/"] + for {set j -1} {$j < [llength $pieces]} {incr j} { + lappend result /[join [lrange $pieces 0 $j] "/"] + } + return $result + } + + method getCookies {proto host path} { upvar 1 state state set result {} - db transaction { - # Open question: how to move these manipulations into the - # database engine (if that's where they *should* be) - # Suggestion from kbk - #LENGTH(theColumn) <= LENGTH($queryStr) AND SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr - set pathbits [split [string trimleft $path "/"] "/"] - set hostbits [split $host "."] - if {[regexp {[^0-9.]} $host]} { - for {set i [llength $hostbits]} {[incr i -1] >= 0} {} { - set domain [join [lrange $hostbits $i end] "."] - for {set j -1} {$j < [llength $pathbits]} {incr j} { - set p /[join [lrange $pathbits 0 $j] "/"] - my GetCookiesForHostAndPath result $domain $p + set paths [my SplitPath $path] + set domains [my SplitDomain $host] + set secure [string equal -nocase $proto "https"] + # Open question: how to move these manipulations into the database + # engine (if that's where they *should* be) + # Suggestion from kbk: + #LENGTH(theColumn) <= LENGTH($queryStr) AND SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr + if {[regexp {[^0-9.]} $host]} { + db transaction { + foreach domain $domains { + foreach p $paths { + my GetCookiesForHostAndPath result $secure $domain $p $host } } - } else { - for {set j -1} {$j < [llength $pathbits]} {incr j} { - set p /[join [lrange $pathbits 0 $j] "/"] - my GetCookiesForHostAndPath result $host $p + } + } else { + db transaction { + foreach p $paths { + my GetCookiesForHostAndPath result $secure $host $p $host } } } @@ -184,41 +218,55 @@ namespace eval ::http { } dict with options {} if {$domain ne $origin} { - http::Log "cookie domain varies from origin ($domain, $origin)" + log debug "cookie domain varies from origin ($domain, $origin)" + } + if {![regexp {[^0-9.]} $domain]} { + if {$domain eq $origin} { + # May set for itself + return 0 + } + log warn "bad cookie: for a numeric address" + return 1 } if {[db exists { SELECT 1 FROM permitted WHERE domain = $domain }]} {return 0} if {[db exists { SELECT 1 FROM forbidden WHERE domain = $domain - }]} {return 1} + }]} { + log warn "bad cookie: for a forbidden address" + return 1 + } if {[regexp {^[^.]+\.(.+)$} $domain -> super]} { if {[db exists { SELECT 1 FROM forbiddenSuper WHERE domain = $super - }]} {return 1} + }]} { + log warn "bad cookie: for a forbidden address" + return 1 + } } return 0 } - method DeleteCookie {domain path key} { + method DeleteCookie {secure domain path key} { db eval { DELETE FROM cookies - WHERE domain = $domain AND key = $name AND path = $path + WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } - incr deletions [db changes] + set del [db changes] db eval { DELETE FROM sessionCookies - WHERE domain = $domain AND key = $name AND path = $path + WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } - incr deletions [db changes] - http::Log "deleted cookies for $domain, $path, $path" + incr deletions [incr del [db changes]] + log debug "deleted $del cookies for [my RenderLocation $secure $domain $path $key]" } + method storeCookie {name val options} { upvar 1 state state set now [clock seconds] db transaction { if {[my BadDomain $options]} { - http::Log "Warning: evil cookie detected" return } dict with options {} @@ -226,20 +274,24 @@ namespace eval ::http { ### FIXME db eval { INSERT OR REPLACE INTO sessionCookies ( - origin, domain, path, key, value) - VALUES ($origin, $domain, $path, $key, $value) + secure, domain, path, key, value, originonly) + VALUES ($secure, $domain, $path, $key, $value, $hostonly); + DELETE FROM cookies + WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } - http::Log "defined session cookie for $domain, $path, $key" + log debug "defined session cookie for [my RenderLocation $secure $domain $path $key]" } elseif {$expires < $now} { - my DeleteCookie $domain $path $key + my DeleteCookie $secure $domain $path $key } else { ### FIXME db eval { INSERT OR REPLACE INTO cookies ( - origin, domain, path, key, value, expiry) - VALUES ($origin, $domain, $path, $key, $value, $expires) + secure, domain, path, key, value, originonly, expiry) + VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires); + DELETE FROM sessionCookies + WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } - http::Log "defined persistent cookie for $domain, $path, $key expires at [clock format $expires]" + log debug "defined persistent cookie for [my RenderLocation $secure $host $path $key], expires at [clock format $expires]" } } } @@ -247,7 +299,7 @@ namespace eval ::http { method PurgeCookies {} { set aid [after 60000 [namespace current]::my PurgeCookies] set now [clock seconds] - http::Log "purging cookies that expired before [clock format $now]" + log debug "purging cookies that expired before [clock format $now]" db transaction { db eval { DELETE FROM cookies WHERE expiry < $now @@ -255,6 +307,7 @@ namespace eval ::http { incr deletions [db changes] if {$deletions > 100} { set deletions 0 + log debug "vacuuming cookie database" db eval { VACUUM } @@ -266,3 +319,5 @@ namespace eval ::http { forward Database db } + +package provide cookiejar $::http::cookiejar_version diff --git a/library/http/http.tcl b/library/http/http.tcl index e434a45..746603f 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -88,7 +88,7 @@ namespace eval http { } # Regular expression used to parse cookies - variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u0100-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]*)(?:\s*;\s*([^\u0000]+))?} + variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]*)(?:\s*;\s*([^\u0000]+))?} namespace export geturl config reset wait formatQuery register unregister # Useful, but not exported: data size status code @@ -732,11 +732,14 @@ proc http::geturl {url args} { seek $state(-querychannel) $start } + # Note that we don't do Cookie2; that's much nastier and not normally + # observed in practice either. It also doesn't fix the multitude of + # bugs in the basic cookie spec. if {$http(-cookiejar) ne ""} { set cookies "" set separator "" foreach {key value} [{*}$http(-cookiejar) \ - getCookies $proto $host $port $state(path)] { + getCookies $proto $host $state(path)] { append cookies $separator $key = $value set separator "; " } @@ -1192,7 +1195,7 @@ proc http::ParseCookie {token value} { # Convert the options into a list before feeding into the cookie store; # ugly, but quite easy. - set realopts {persistent 0 hostonly 1 path /} + set realopts {persistent 0 hostonly 1 path / secure 0} dict set realopts origin $state(host) dict set realopts domain $state(host) foreach opt [split [regsub -all {;\s+} $opts \u0000] \u0000] { @@ -1211,6 +1214,9 @@ proc http::ParseCookie {token value} { [clock scan $opt -format "%a, %d-%b-%Y %T %Z"] dict set realopts persistent 1 }] && [catch { + # This is in the RFC, but it is also in the original + # Netscape cookie spec, now online at: + # #Sunday, 06-Nov-94 08:49:37 GMT dict set realopts expires \ [clock scan $opt -format "%A, %d-%b-%y %T %Z"] @@ -1232,9 +1238,9 @@ proc http::ParseCookie {token value} { } Domain=* { set opt [string trimleft [string range $opt 7 end] "."] - # TODO - Domain safety check! if {$opt ne "" && ![string match *. $opt]} { dict set realopts domain $opt + dict set realopts hostonly 0 } } Path=* { -- cgit v0.12 From dcb740cc8314b235fd1b2d6275ace3194510ffc0 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Sep 2012 19:01:32 +0000 Subject: 3564735 Protection against namespace var resolvers that unexpectedly return a pointer to Var while Tcl expects pointer to VarInHash. This may not be the total solution to Bug 3564735 (Itcl may be misbehaving), but this will prevent memory corruption. --- generic/tclInt.h | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index e1ce6d5..cca9938 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -693,13 +693,17 @@ typedef struct VarInHash { #define TclSetVarNamespaceVar(varPtr) \ if (!TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags |= VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount++;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount++;\ + }\ } #define TclClearVarNamespaceVar(varPtr) \ if (TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount--;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount--;\ + }\ } /* -- cgit v0.12 From ddb07346c093db91c8ac9cff07843d135067ac3d Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 6 Sep 2012 19:18:37 +0000 Subject: Tidy up, making code be of higher general quality. --- library/http/cookiejar.tcl | 27 +++++++++++++-------------- library/http/http.tcl | 2 +- 2 files changed, 14 insertions(+), 15 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 30720f8..9a02834 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -20,13 +20,14 @@ namespace eval ::http { ::http::Log [string toupper $level]:cookiejar($origin):${msg} } } - method loglevel {level} { + method loglevel {{level "\u0000\u0000"}} { upvar 0 ::http::cookiejar_loglevel loglevel if {$level in {debug info warn error}} { set loglevel $level - } else { + } elseif {$level ne "\u0000\u0000"} { return -code error "unknown log level \"$level\": must be debug, info, warn, or error" } + return $loglevel } } @@ -76,6 +77,14 @@ namespace eval ::http { set aid [after 60000 [namespace current]::my PurgeCookies] # TODO: domain list refresh policy + db eval { + CREATE TABLE IF NOT EXISTS forbidden ( + domain TEXT PRIMARY KEY); + CREATE TABLE IF NOT EXISTS forbiddenSuper ( + domain TEXT PRIMARY KEY); + CREATE TABLE IF NOT EXISTS permitted ( + domain TEXT PRIMARY KEY); + } if {$path ne ""} { if {![db exists { SELECT 1 FROM sqlite_master @@ -91,14 +100,6 @@ namespace eval ::http { method InitDomainList {} { # TODO: Handle IDNs (but Tcl overall gets that wrong at the moment...) variable ::http::cookiejar_domainlist - db eval { - CREATE TABLE IF NOT EXISTS forbidden ( - domain TEXT PRIMARY KEY); - CREATE TABLE IF NOT EXISTS forbiddenSuper ( - domain TEXT PRIMARY KEY); - CREATE TABLE IF NOT EXISTS permitted ( - domain TEXT PRIMARY KEY); - } log debug "loading domain list from $cookiejar_domainlist" set tok [http::geturl $cookiejar_domainlist] try { @@ -150,8 +151,8 @@ namespace eval ::http { } } - method GetCookiesForHostAndPath {*result secure host path fullhost} { - upvar 1 ${*result} result + method GetCookiesForHostAndPath {listVar secure host path fullhost} { + upvar 1 $listVar result log debug "check for cookies for [my RenderLocation $secure $host $path]" db eval { SELECT key, value FROM cookies @@ -185,7 +186,6 @@ namespace eval ::http { } method getCookies {proto host path} { - upvar 1 state state set result {} set paths [my SplitPath $path] set domains [my SplitDomain $host] @@ -263,7 +263,6 @@ namespace eval ::http { } method storeCookie {name val options} { - upvar 1 state state set now [clock seconds] db transaction { if {[my BadDomain $options]} { diff --git a/library/http/http.tcl b/library/http/http.tcl index 746603f..98ed71b 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1195,7 +1195,7 @@ proc http::ParseCookie {token value} { # Convert the options into a list before feeding into the cookie store; # ugly, but quite easy. - set realopts {persistent 0 hostonly 1 path / secure 0} + set realopts {persistent 0 hostonly 1 path / secure 0 httponly 0} dict set realopts origin $state(host) dict set realopts domain $state(host) foreach opt [split [regsub -all {;\s+} $opts \u0000] \u0000] { -- cgit v0.12 From 9e6f2e579a4491d2cbcb251d6b2f098210426be2 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 7 Sep 2012 07:13:44 +0000 Subject: improving the database, working towards a purging algorithm for session cookies --- library/http/cookiejar.tcl | 75 +++++++++++++++++++++++++++++----------------- 1 file changed, 48 insertions(+), 27 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 9a02834..20ed7a0 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -17,7 +17,11 @@ namespace eval ::http { upvar 0 ::http::cookiejar_loglevel loglevel set map {debug 0 info 1 warn 2 error 3} if {[string map $map $level] >= [string map $map $loglevel]} { - ::http::Log [string toupper $level]:cookiejar($origin):${msg} + set ms [clock milliseconds] + set ts [expr {$ms / 1000}] + set ms [format %03d [expr {$ms % 1000}]] + set t [clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1] + ::http::Log ${t}:[string toupper $level]:cookiejar($origin):${msg} } } method loglevel {{level "\u0000\u0000"}} { @@ -39,10 +43,11 @@ namespace eval ::http { sqlite3 [namespace current]::db $path db timeout 500 } - proc log {level msg} "::http::cookiejar log [list [self]] \$level \$msg" + proc log {level msg} \ + "::http::cookiejar log [list [self]] \$level \$msg" set deletions 0 db eval { - CREATE TABLE IF NOT EXISTS cookies ( + CREATE TABLE IF NOT EXISTS persistentCookies ( id INTEGER PRIMARY KEY, secure INTEGER NOT NULL, domain TEXT NOT NULL COLLATE NOCASE, @@ -50,10 +55,14 @@ namespace eval ::http { key TEXT NOT NULL, value TEXT NOT NULL, originonly INTEGER NOT NULL, - expiry INTEGER NOT NULL); - CREATE UNIQUE INDEX IF NOT EXISTS cookieUnique - ON cookies (secure, domain, path, key) + expiry INTEGER NOT NULL, + creation INTEGER NOT NULL); + CREATE UNIQUE INDEX IF NOT EXISTS persistentUnique + ON persistentCookies (domain, path, key); + CREATE INDEX IF NOT EXISTS persistentLookup + ON persistentCookies (domain, path); } + ## TODO: Are there "TEMP INDEX"es? db eval { CREATE TEMP TABLE sessionCookies ( id INTEGER PRIMARY KEY, @@ -62,13 +71,17 @@ namespace eval ::http { path TEXT NOT NULL, key TEXT NOT NULL, originonly INTEGER NOT NULL, - value TEXT NOT NULL); + value TEXT NOT NULL, + lastuse INTEGER NOT NULL, + creation INTEGER NOT NULL); CREATE UNIQUE INDEX sessionUnique - ON sessionCookies (secure, domain, path, key) + ON sessionCookies (domain, path, key); + CREATE INDEX sessionLookup ON sessionCookies (domain, path); } + ## TODO: Consider creating a view db eval { - SELECT COUNT(*) AS cookieCount FROM cookies + SELECT COUNT(*) AS cookieCount FROM persistentCookies } if {[info exist cookieCount] && $cookieCount} { log info "loaded cookie store from $path with $cookieCount entries" @@ -155,18 +168,23 @@ namespace eval ::http { upvar 1 $listVar result log debug "check for cookies for [my RenderLocation $secure $host $path]" db eval { - SELECT key, value FROM cookies - WHERE secure <= $secure AND domain = $host AND path = $path + SELECT key, value FROM persistentCookies + WHERE domain = $host AND path = $path AND secure <= $secure AND (NOT originonly OR domain = $fullhost) - } cookie { - lappend result $cookie(key) $cookie(value) + } { + lappend result $key $value } + set now [clock seconds] db eval { - SELECT key, value FROM sessionCookies - WHERE secure <= $secure AND domain = $host AND path = $path + SELECT id, key, value FROM sessionCookies + WHERE domain = $host AND path = $path AND secure <= $secure AND (NOT originonly OR domain = $fullhost) - } cookie { - lappend result $cookie(key) $cookie(value) + } { + lappend result $key $value + ## FIXME: check syntax! + db eval { + UPDATE sessionCookies SET lastuse = $now WHERE id = $id + } } } @@ -250,13 +268,15 @@ namespace eval ::http { method DeleteCookie {secure domain path key} { db eval { - DELETE FROM cookies - WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key + DELETE FROM persistentCookies + WHERE domain = $domain AND path = $path AND key = $key + AND secure <= $secure } set del [db changes] db eval { DELETE FROM sessionCookies - WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key + WHERE domain = $domain AND path = $path AND key = $key + AND secure <= $secure } incr deletions [incr del [db changes]] log debug "deleted $del cookies for [my RenderLocation $secure $domain $path $key]" @@ -268,14 +288,15 @@ namespace eval ::http { if {[my BadDomain $options]} { return } + set now [clock seconds] dict with options {} if {!$persistent} { ### FIXME db eval { INSERT OR REPLACE INTO sessionCookies ( - secure, domain, path, key, value, originonly) - VALUES ($secure, $domain, $path, $key, $value, $hostonly); - DELETE FROM cookies + secure, domain, path, key, value, originonly, creation) + VALUES ($secure, $domain, $path, $key, $value, $hostonly, $now); + DELETE FROM persistentCookies WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } log debug "defined session cookie for [my RenderLocation $secure $domain $path $key]" @@ -284,9 +305,9 @@ namespace eval ::http { } else { ### FIXME db eval { - INSERT OR REPLACE INTO cookies ( - secure, domain, path, key, value, originonly, expiry) - VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires); + INSERT OR REPLACE INTO persistentCookies ( + secure, domain, path, key, value, originonly, expiry, creation) + VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires, $now); DELETE FROM sessionCookies WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } @@ -301,7 +322,7 @@ namespace eval ::http { log debug "purging cookies that expired before [clock format $now]" db transaction { db eval { - DELETE FROM cookies WHERE expiry < $now + DELETE FROM persistentCookies WHERE expiry < $now } incr deletions [db changes] if {$deletions > 100} { -- cgit v0.12 From ee1f2a248415d2bef750da1b3622983c2432cc54 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 7 Sep 2012 10:35:14 +0000 Subject: More improvements --- library/http/cookiejar.tcl | 218 ++++++++++++++++++++++++++------------------- 1 file changed, 128 insertions(+), 90 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 20ed7a0..e11fce1 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -1,52 +1,97 @@ -package require Tcl 8.5 -package require TclOO -package require http 2.7;#2.8.4 +# Cookie Jar package. + +# Dependencies +package require Tcl 8.5;# FIXME: JUST DURING DEVELOPMENT +package require TclOO;# FIXME: JUST DURING DEVELOPMENT +package require http 2.7;# FIXME: JUST DURING DEVELOPMENT +#package require Tcl 8.6 +#package require http 2.8.4 package require sqlite3 +# Configuration for the cookiejar package namespace eval ::http { # TODO: is this the _right_ list of domains to use? variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 variable cookiejar_version 0.1 variable cookiejar_loglevel info -} + variable cookiejar_vacuumtrigger 200 + + # This is the class that we are creating + ::oo::class create cookiejar -::oo::class create ::http::cookiejar { - self { - method log {origin level msg} { + # Some support procedures, none particularly useful in general + namespace eval cookiejar_support { + namespace export * + proc locn {secure domain path {key ""}} { + if {$key eq ""} { + format "%s://%s%s" [expr {$secure?"https":"http"}] $domain $path + } else { + format "%s://%s%s?%s" \ + [expr {$secure?"https":"http"}] $domain $path $key + } + } + proc splitDomain domain { + set pieces [split $domain "."] + for {set i [llength $pieces]} {[incr i -1] >= 0} {} { + lappend result [join [lrange $pieces $i end] "."] + } + return $result + } + proc splitPath path { + set pieces [split [string trimleft $path "/"] "/"] + for {set j -1} {$j < [llength $pieces]} {incr j} { + lappend result /[join [lrange $pieces 0 $j] "/"] + } + return $result + } + proc isoNow {} { + set ms [clock milliseconds] + set ts [expr {$ms / 1000}] + set ms [format %03d [expr {$ms % 1000}]] + clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1 + } + proc log {level msg} { upvar 0 ::http::cookiejar_loglevel loglevel + set who [uplevel 1 self] set map {debug 0 info 1 warn 2 error 3} if {[string map $map $level] >= [string map $map $loglevel]} { - set ms [clock milliseconds] - set ts [expr {$ms / 1000}] - set ms [format %03d [expr {$ms % 1000}]] - set t [clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1] - ::http::Log ${t}:[string toupper $level]:cookiejar($origin):${msg} + ::http::Log "[isoNow] [string toupper $level] cookiejar($who) - ${msg}" } } - method loglevel {{level "\u0000\u0000"}} { - upvar 0 ::http::cookiejar_loglevel loglevel - if {$level in {debug info warn error}} { - set loglevel $level - } elseif {$level ne "\u0000\u0000"} { - return -code error "unknown log level \"$level\": must be debug, info, warn, or error" - } - return $loglevel + } +} + +# Now we have enough information to provide the package. +package provide cookiejar $::http::cookiejar_version + +# The implementation of the cookiejar package +::oo::define ::http::cookiejar { + self method loglevel {{level "\u0000\u0000"}} { + upvar 0 ::http::cookiejar_loglevel loglevel + if {$level in {debug info warn error}} { + set loglevel $level + } elseif {$level ne "\u0000\u0000"} { + return -code error "unknown log level \"$level\": must be debug, info, warn, or error" } + return $loglevel } variable aid deletions constructor {{path ""}} { + namespace import ::http::cookiejar_support::* + if {$path eq ""} { sqlite3 [namespace current]::db :memory: } else { sqlite3 [namespace current]::db $path db timeout 500 } - proc log {level msg} \ - "::http::cookiejar log [list [self]] \$level \$msg" + set deletions 0 db eval { + --;# Store the persistent cookies in this table. + --;# Deletion policy: once they expire, or if explicitly killed. CREATE TABLE IF NOT EXISTS persistentCookies ( id INTEGER PRIMARY KEY, secure INTEGER NOT NULL, @@ -58,12 +103,14 @@ namespace eval ::http { expiry INTEGER NOT NULL, creation INTEGER NOT NULL); CREATE UNIQUE INDEX IF NOT EXISTS persistentUnique - ON persistentCookies (domain, path, key); + ON persistentCookies (domain, path, key); CREATE INDEX IF NOT EXISTS persistentLookup - ON persistentCookies (domain, path); - } - ## TODO: Are there "TEMP INDEX"es? - db eval { + ON persistentCookies (domain, path); + + --;# Store the session cookies in this table. + --;# Deletion policy: at cookiejar instance deletion, if + --;# explicitly killed, or if the number of session cookies is too + --;# large and the cookie has not been used recently. CREATE TEMP TABLE sessionCookies ( id INTEGER PRIMARY KEY, secure INTEGER NOT NULL, @@ -75,10 +122,19 @@ namespace eval ::http { lastuse INTEGER NOT NULL, creation INTEGER NOT NULL); CREATE UNIQUE INDEX sessionUnique - ON sessionCookies (domain, path, key); + ON sessionCookies (domain, path, key); CREATE INDEX sessionLookup ON sessionCookies (domain, path); + + --;# View to allow for simple looking up of a cookie. + CREATE TEMP VIEW cookies AS + SELECT id, domain, path, key, value, originonly, secure, + 1 AS persistent + FROM persistentCookies + UNION + SELECT id, domain, path, key, value, originonly, secure, + 0 AS persistent + FROM sessionCookies; } - ## TODO: Consider creating a view db eval { SELECT COUNT(*) AS cookieCount FROM persistentCookies @@ -91,10 +147,17 @@ namespace eval ::http { # TODO: domain list refresh policy db eval { + --;# Domains that may not have a cookie defined for them. CREATE TABLE IF NOT EXISTS forbidden ( domain TEXT PRIMARY KEY); + + --;# Domains that may not have a cookie defined for direct child + --;# domains of them. CREATE TABLE IF NOT EXISTS forbiddenSuper ( domain TEXT PRIMARY KEY); + + --;# Domains that *may* have a cookie defined for them, used to + --;# define exceptions for the forbiddenSuper table. CREATE TABLE IF NOT EXISTS permitted ( domain TEXT PRIMARY KEY); } @@ -155,18 +218,9 @@ namespace eval ::http { db close } - method RenderLocation {secure domain path {key ""}} { - if {$key eq ""} { - format "%s://%s%s" [expr {$secure?"https":"http"}] $domain $path - } else { - format "%s://%s%s?%s" \ - [expr {$secure?"https":"http"}] $domain $path $key - } - } - method GetCookiesForHostAndPath {listVar secure host path fullhost} { upvar 1 $listVar result - log debug "check for cookies for [my RenderLocation $secure $host $path]" + log debug "check for cookies for [locn $secure $host $path]" db eval { SELECT key, value FROM persistentCookies WHERE domain = $host AND path = $path AND secure <= $secure @@ -181,35 +235,19 @@ namespace eval ::http { AND (NOT originonly OR domain = $fullhost) } { lappend result $key $value - ## FIXME: check syntax! db eval { UPDATE sessionCookies SET lastuse = $now WHERE id = $id } } } - method SplitDomain domain { - set pieces [split $domain "."] - for {set i [llength $pieces]} {[incr i -1] >= 0} {} { - lappend result [join [lrange $pieces $i end] "."] - } - return $result - } - method SplitPath path { - set pieces [split [string trimleft $path "/"] "/"] - for {set j -1} {$j < [llength $pieces]} {incr j} { - lappend result /[join [lrange $pieces 0 $j] "/"] - } - return $result - } - method getCookies {proto host path} { set result {} - set paths [my SplitPath $path] - set domains [my SplitDomain $host] + set paths [splitPath $path] + set domains [splitDomain $host] set secure [string equal -nocase $proto "https"] # Open question: how to move these manipulations into the database - # engine (if that's where they *should* be) + # engine (if that's where they *should* be). # Suggestion from kbk: #LENGTH(theColumn) <= LENGTH($queryStr) AND SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr if {[regexp {[^0-9.]} $host]} { @@ -266,22 +304,6 @@ namespace eval ::http { return 0 } - method DeleteCookie {secure domain path key} { - db eval { - DELETE FROM persistentCookies - WHERE domain = $domain AND path = $path AND key = $key - AND secure <= $secure - } - set del [db changes] - db eval { - DELETE FROM sessionCookies - WHERE domain = $domain AND path = $path AND key = $key - AND secure <= $secure - } - incr deletions [incr del [db changes]] - log debug "deleted $del cookies for [my RenderLocation $secure $domain $path $key]" - } - method storeCookie {name val options} { set now [clock seconds] db transaction { @@ -291,32 +313,45 @@ namespace eval ::http { set now [clock seconds] dict with options {} if {!$persistent} { - ### FIXME db eval { INSERT OR REPLACE INTO sessionCookies ( - secure, domain, path, key, value, originonly, creation) - VALUES ($secure, $domain, $path, $key, $value, $hostonly, $now); + secure, domain, path, key, value, originonly, creation, lastuse) + VALUES ($secure, $domain, $path, $key, $value, $hostonly, $now, $now); DELETE FROM persistentCookies - WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key + WHERE domain = $domain AND path = $path AND key = $key AND secure <= $secure } - log debug "defined session cookie for [my RenderLocation $secure $domain $path $key]" + incr deletions [db changes] + log debug "defined session cookie for [locn $secure $domain $path $key]" } elseif {$expires < $now} { - my DeleteCookie $secure $domain $path $key + db eval { + DELETE FROM persistentCookies + WHERE domain = $domain AND path = $path AND key = $key + AND secure <= $secure; + } + set del [db changes] + db eval { + DELETE FROM sessionCookies + WHERE domain = $domain AND path = $path AND key = $key + AND secure <= $secure; + } + incr deletions [incr del [db changes]] + log debug "deleted $del cookies for [locn $secure $domain $path $key]" } else { - ### FIXME db eval { INSERT OR REPLACE INTO persistentCookies ( secure, domain, path, key, value, originonly, expiry, creation) VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires, $now); DELETE FROM sessionCookies - WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key + WHERE domain = $domain AND path = $path AND key = $key AND secure <= $secure } - log debug "defined persistent cookie for [my RenderLocation $secure $host $path $key], expires at [clock format $expires]" + incr deletions [db changes] + log debug "defined persistent cookie for [locn $secure $domain $path $key], expires at [clock format $expires]" } } } method PurgeCookies {} { + upvar 0 ::http::cookiejar_vacuumtrigger vacuumtrigger set aid [after 60000 [namespace current]::my PurgeCookies] set now [clock seconds] log debug "purging cookies that expired before [clock format $now]" @@ -325,19 +360,22 @@ namespace eval ::http { DELETE FROM persistentCookies WHERE expiry < $now } incr deletions [db changes] - if {$deletions > 100} { - set deletions 0 - log debug "vacuuming cookie database" + } + ### TODO: Cap the total number of cookies and session cookies, + ### purging least frequently used + + # Once we've deleted a fair bit, vacuum the database. Must be done + # outside a transaction. + if {$deletions > $vacuumtrigger} { + set deletions 0 + log debug "vacuuming cookie database" + catch { db eval { VACUUM } } } - ### TODO: Cap the total number of cookies and session cookies, - ### purging least frequently used } forward Database db } - -package provide cookiejar $::http::cookiejar_version -- cgit v0.12 From 4596fb2059e8fe8f751eba9ff3949fa9f2545fae Mon Sep 17 00:00:00 2001 From: ferrieux Date: Fri, 7 Sep 2012 14:44:46 +0000 Subject: Backport of 2008-12-12 8.6 commit: Fix missing CLOEXEC on internal pipes [2417695] --- ChangeLog | 5 +++++ unix/tclUnixNotfy.c | 6 ++++++ win/buildall.vc.bat | 0 3 files changed, 11 insertions(+) mode change 100644 => 100755 win/buildall.vc.bat diff --git a/ChangeLog b/ChangeLog index 18cdf37..b0fed83 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-09-07 Alexandre Ferrieux + + * unix/tclUnixNotfy.c Backport of 2008-12-12 8.6 commit: Fix + missing CLOEXEC on internal pipes [2417695] + 2012-08-25 Donal K. Fellows * library/msgs/uk.msg: [Bug 3561330]: Use the correct full name of diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index 42cc7be..51f0b1f 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -1057,6 +1057,12 @@ NotifierThreadProc( if (TclUnixSetBlockingMode(fds[1], TCL_MODE_NONBLOCKING) < 0) { Tcl_Panic("NotifierThreadProc: could not make trigger pipe non blocking"); } + if (fcntl(receivePipe, F_SETFD, FD_CLOEXEC) < 0) { + Tcl_Panic("NotifierThreadProc: could not make receive pipe close-on-exec"); + } + if (fcntl(fds[1], F_SETFD, FD_CLOEXEC) < 0) { + Tcl_Panic("NotifierThreadProc: could not make trigger pipe close-on-exec"); + } /* * Install the write end of the pipe into the global variable. diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat old mode 100644 new mode 100755 -- cgit v0.12 From 47f4e0b416dd3a8379b0fc5178db7ecca5b74eae Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 7 Sep 2012 15:32:15 +0000 Subject: Reentrant mcfl(m)set command, test, document mcflset as recommended for message files --- doc/msgcat.n | 12 ++++++------ library/msgcat/msgcat.tcl | 12 ++++++++---- tests/msgcat.test | 44 ++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 56 insertions(+), 12 deletions(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index d65563a..af6be7f 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -139,7 +139,7 @@ returns the number of translations set. .TP \fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? .VS "TIP 404" -Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the the +Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the current namespace for the locale implied by the name of the message catalog being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not specified, \fIsrc-string\fR is used for both. The function returns @@ -153,8 +153,8 @@ the current namespace for the locale implied by the name of the message catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must have an even number of elements and is in the form {\fIsrc-string translate-string\fR ?\fIsrc-string translate-string ...\fR?} -\fB::msgcat::mcmset\fR can be significantly faster than multiple invocations -of \fB::msgcat::mcset\fR. The function returns the number of translations set. +\fB::msgcat::mcflmset\fR can be significantly faster than multiple invocations +of \fB::msgcat::mcflset\fR. The function returns the number of translations set. .VE "TIP 404" .TP \fB::msgcat::mcunknown \fIlocale src-string\fR @@ -312,15 +312,15 @@ cause peculiar behavior, such as marking the message file as .QW hidden on Unix file systems. .IP [3] -The file contains a series of calls to \fBmcset\fR and -\fBmcmset\fR, setting the necessary translation strings +The file contains a series of calls to \fBmcflset\fR and +\fBmcflmset\fR, setting the necessary translation strings for the language, likely enclosed in a \fBnamespace eval\fR so that all source strings are tied to the namespace of the package. For example, a short \fBes.msg\fR might contain: .PP .CS namespace eval ::mypackage { - \fB::msgcat::mcset\fR es "Free Beer!" "Cerveza Gracias!" + \fB::msgcat::mcflset\fR "Free Beer!" "Cerveza Gracias!" } .CE .SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES" diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 6dd44d2..112507a 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -25,10 +25,7 @@ namespace eval msgcat { # Records the list of locales to search variable Loclist {} - # Records the locale of the currently sourced message catalogue file; this - # would be problematic if anyone were to recursively load a message - # catalog for a different locale from inside a catalog, but that's not a - # case that we really need to worry about. + # Records the locale of the currently sourced message catalogue file variable FileLocale # Records the mapping between source strings and translated strings. The @@ -284,6 +281,10 @@ proc msgcat::mcpreferences {} { proc msgcat::mcload {langdir} { variable FileLocale + # Save the file locale if we are recursively called + if {[info exists FileLocale]} { + set nestedFileLocale $FileLocale + } set x 0 foreach p [mcpreferences] { if { $p eq {} } { @@ -300,6 +301,9 @@ proc msgcat::mcload {langdir} { unset FileLocale } } + if {[info exists nestedFileLocale]} { + set FileLocale $nestedFileLocale + } return $x } diff --git a/tests/msgcat.test b/tests/msgcat.test index bbcd023..d75bf8e 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -17,8 +17,8 @@ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } -if {[catch {package require msgcat 1.4.5}]} { - puts stderr "Skipping tests in [info script]. No msgcat 1.4.5 found to test." +if {[catch {package require msgcat 1.5.0}]} { + puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test." return } @@ -611,6 +611,46 @@ namespace eval ::msgcat::test { mc "this is a %s" "good test" } -result "this is a good test" + # Tests msgcat-8.*: [mcflset] + + set msgdir1 [makeDirectory msgdir1] + makeFile {::msgcat::mcflset k1 v1} l1.msg $msgdir1 + + test msgcat-8.1 {mcflset} -setup { + variable locale [mclocale] + mclocale l1 + mcload $msgdir1 + } -cleanup { + mclocale $locale + } -body { + mc k1 + } -result v1 + + removeFile l1.msg $msgdir1 + removeDirectory msgdir1 + + set msgdir2 [makeDirectory msgdir2] + set msgdir3 [makeDirectory msgdir3] + makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\ + l2.msg $msgdir2 + makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3 + + # chained mcload + test msgcat-8.2 {mcflset} -setup { + variable locale [mclocale] + mclocale l2 + mcload $msgdir2 + } -cleanup { + mclocale $locale + } -body { + return [mc k2][mc k3] + } -result v2v3 + + removeFile l2.msg $msgdir2 + removeDirectory msgdir2 + removeFile l3.msg $msgdir3 + removeDirectory msgdir3 + cleanupTests } namespace delete ::msgcat::test -- cgit v0.12 From 25ea4d4aeb2f090ed183865a6ee290e33db9ecd6 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 7 Sep 2012 17:22:53 +0000 Subject: ChangeLog entry added --- ChangeLog | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 68f2441..036cd21 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-09-07 Harald Oehlmann + + IMPLEMENTATION OF TIP#404. + + * library/msgcat.tcl: [FRQ 3544988]: add commands + [mcflset] and [mcflmset] to set mc entries with implicit message file + locale. Package version is now 1.5.0. + 2012-08-25 Donal K. Fellows * library/msgs/uk.msg: [Bug 3561330]: Use the correct full name of @@ -186,7 +194,7 @@ * library/msgcat/msgcat.tcl: Add tn, ro_MO and ru_MO to msgcat. -2012-06-29 Harald Oehlmann +2012-06-29 Harald Oehlmann * library/msgcat/msgcat.tcl: [Bug 3536888]: Locale guessing of * library/msgcat/pkgIndex.tcl: msgcat fails on (some) Windows 7. Bump -- cgit v0.12 From 796e60b23562fa917a17f1df0be24ec4502713ee Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Sep 2012 21:01:14 +0000 Subject: removed leftover from failed attempt to unify stub tables. --- generic/tclStubInit.c | 8 -------- 1 file changed, 8 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 0fc35d5..a8d74ee 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -169,14 +169,6 @@ Tcl_WinTCharToUtf( string, len, dsPtr); } -#define TclMacOSXGetFileAttribute (int (*) (Tcl_Interp *, \ - int, Tcl_Obj *, Tcl_Obj **)) TclpCreateProcess -#define TclMacOSXMatchType (int (*) (Tcl_Interp *, const char *, \ - const char *, Tcl_StatBuf *, Tcl_GlobTypeData *)) TclpMakeFile -#define TclMacOSXNotifierAddRunLoopMode (void (*) (const void *)) TclpOpenFile -#define TclpLocaltime_unix (struct tm *(*) (const time_t *)) TclGetAndDetachPids -#define TclpGmtime_unix (struct tm *(*) (const time_t *)) TclpCloseFile - #else /* UNIX and MAC */ # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime -- cgit v0.12 From 496e8dc792f5f8a9fbd7908346b73565fbaf5c87 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Sep 2012 21:58:56 +0000 Subject: Experiment: MSVC build now links with 64-bit zlib1.dll --- compat/zlib/win32/zdll.lib | Bin 13438 -> 15256 bytes compat/zlib/win64/zdll.lib | Bin 45650 -> 14896 bytes win/configure | 9 --------- win/configure.in | 4 ---- 4 files changed, 13 deletions(-) diff --git a/compat/zlib/win32/zdll.lib b/compat/zlib/win32/zdll.lib index 4e53491..669b186 100644 Binary files a/compat/zlib/win32/zdll.lib and b/compat/zlib/win32/zdll.lib differ diff --git a/compat/zlib/win64/zdll.lib b/compat/zlib/win64/zdll.lib index 084dbff..d7dfb09 100644 Binary files a/compat/zlib/win64/zdll.lib and b/compat/zlib/win64/zdll.lib differ diff --git a/win/configure b/win/configure index 5cf1513..3e08d5d 100755 --- a/win/configure +++ b/win/configure @@ -4344,12 +4344,6 @@ esac # as we just assume that the platform hasn't got a usable z.lib #------------------------------------------------------------------------ -if test "$do64bit" = "yes" && test "$GCC" != "yes"; then - - tcl_ok=no - -else - if test "${enable_shared+set}" = "set"; then enableval="$enable_shared" @@ -4361,9 +4355,6 @@ else fi - -fi - if test "$tcl_ok" = "yes"; then ZLIB_DLL_FILE=\${ZLIB_DLL_FILE} diff --git a/win/configure.in b/win/configure.in index de56bf7..cd6088e 100644 --- a/win/configure.in +++ b/win/configure.in @@ -120,16 +120,12 @@ esac # as we just assume that the platform hasn't got a usable z.lib #------------------------------------------------------------------------ -AS_IF([test "$do64bit" = "yes" && test "$GCC" != "yes"], [ - tcl_ok=no -], [ AS_IF([test "${enable_shared+set}" = "set"], [ enableval="$enable_shared" tcl_ok=$enableval ], [ tcl_ok=yes ]) -]) AS_IF([test "$tcl_ok" = "yes"], [ AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) AS_IF([test "$do64bit" = "yes"], [ -- cgit v0.12 From ef405dbe9cd32dfc4294ae138d66bbac63172a4b Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 9 Sep 2012 12:02:38 +0000 Subject: working on handling punycoding of IDNAs --- library/http/cookiejar.tcl | 290 ++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 261 insertions(+), 29 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index e11fce1..605a621 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -13,6 +13,7 @@ namespace eval ::http { # TODO: is this the _right_ list of domains to use? variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 + # The list is directed to from http://publicsuffix.org/list/ variable cookiejar_version 0.1 variable cookiejar_loglevel info variable cookiejar_vacuumtrigger 200 @@ -59,6 +60,17 @@ namespace eval ::http { ::http::Log "[isoNow] [string toupper $level] cookiejar($who) - ${msg}" } } + proc IDNAencode str { + set parts {} + # Split term from RFC 3490, Sec 3.1 + foreach part [split $str "\u002E\u3002\uFF0E\uFF61"] { + if {![string is ascii $part]} { + set part xn--[puny::encode $part] + } + lappend parts $part + } + return [join $parts .] + } } } @@ -147,26 +159,25 @@ package provide cookiejar $::http::cookiejar_version # TODO: domain list refresh policy db eval { - --;# Domains that may not have a cookie defined for them. - CREATE TABLE IF NOT EXISTS forbidden ( - domain TEXT PRIMARY KEY); + --;# Encoded domain permission policy; if forbidden is 1, no + --;# cookie may be ever set for the domain, and if forbidden is 0, + --;# cookies *may* be created for the domain (overriding the + --;# forbiddenSuper table). + CREATE TABLE IF NOT EXISTS domains ( + domain TEXT PRIMARY KEY NOT NULL, + forbidden INTEGER NOT NULL) --;# Domains that may not have a cookie defined for direct child --;# domains of them. CREATE TABLE IF NOT EXISTS forbiddenSuper ( domain TEXT PRIMARY KEY); - - --;# Domains that *may* have a cookie defined for them, used to - --;# define exceptions for the forbiddenSuper table. - CREATE TABLE IF NOT EXISTS permitted ( - domain TEXT PRIMARY KEY); } if {$path ne ""} { if {![db exists { SELECT 1 FROM sqlite_master - WHERE type='table' AND name='forbidden' + WHERE type='table' AND name='domains' }] && ![db exists { - SELECT 1 FROM forbidden + SELECT 1 FROM domains }]} then { my InitDomainList } @@ -186,21 +197,29 @@ package provide cookiejar $::http::cookiejar_version if {[string match //* $line]} continue if {[string match !* $line]} { set line [string range $line 1 end] + set idna [IDNAencode $line] db eval { - INSERT INTO permitted (domain) - VALUES ($line) + INSERT INTO domains (domain, forbidden) + VALUES ($line, 0); + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 0); } } else { if {[string match {\*.*} $line]} { set line [string range $line 2 end] db eval { INSERT INTO forbiddenSuper (domain) - VALUES ($line) + VALUES ($line); + INSERT OR REPLACE INTO forbiddenSuper (domain) + VALUES ($idna); } } + set idna [IDNAencode $line] db eval { - INSERT INTO forbidden (domain) - VALUES ($line) + INSERT INTO domains (domain, forbidden) + VALUES ($line, 1); + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 1); } } } @@ -284,22 +303,19 @@ package provide cookiejar $::http::cookiejar_version log warn "bad cookie: for a numeric address" return 1 } - if {[db exists { - SELECT 1 FROM permitted WHERE domain = $domain - }]} {return 0} - if {[db exists { - SELECT 1 FROM forbidden WHERE domain = $domain - }]} { - log warn "bad cookie: for a forbidden address" - return 1 - } - if {[regexp {^[^.]+\.(.+)$} $domain -> super]} { - if {[db exists { - SELECT 1 FROM forbiddenSuper WHERE domain = $super - }]} { + db eval { + SELECT forbidden FROM domains WHERE domain = $domain + } { + if {$forbidden} { log warn "bad cookie: for a forbidden address" - return 1 } + return $forbidden + } + if {[regexp {^[^.]+\.(.+)$} $domain -> super] && [db exists { + SELECT 1 FROM forbiddenSuper WHERE domain = $super + }]} then { + log warn "bad cookie: for a forbidden address" + return 1 } return 0 } @@ -379,3 +395,219 @@ package provide cookiejar $::http::cookiejar_version forward Database db } + +# The implementation of the puncode encoder. This is based on the code on +# http://wiki.tcl.tk/10501 but with extensive modifications to be faster when +# encoding. + +# TODO: This gets some strings wrong! + +namespace eval ::http::cookiejar_support::puny { + namespace export encode decode + + variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""] + + # 3.2 Insertion unsort coding + proc insertionUnsort {splitstr extended} { + set oldchar 128 + set result {} + set oldindex -1 + foreach c $extended { + set index -1 + set pos -1 + set curlen 0 + foreach c2 $splitstr { + incr curlen [expr {$c2 < $c}] + } + scan $c "%c" char + set delta [expr {($curlen + 1) * ($char - $oldchar)}] + while true { + for {} {[incr pos] < [llength $splitstr]} {} { + set c2 [lindex $splitstr $pos] + if {$c2 eq $c} { + incr index + break + } elseif {$c2 < $c} { + incr index + } + } + if {$pos == [llength $splitstr]} { + set pos -1 + break + } + lappend result [expr {$delta + $index - $oldindex - 1}] + set oldindex $index + set delta 0 + } + set oldchar $char + } + return $result + } + + # Punycode parameters: tmin = 1, tmax = 26, base = 36 + proc T {j bias} { + return [expr {min(max(36 * ($j + 1) - $bias, 1), 26)}] + } + + # 3.3 Generalized variable-length integers + proc generateGeneralizedInteger {N bias} { + variable digits + set result {} + set j 0 + while true { + set t [T $j $bias] + if {$N < $t} { + return [lappend result [lindex $digits $N]] + } + lappend result [lindex $digits [expr {$t + (($N-$t) % (36-$t))}]] + set N [expr {int(($N-$t) / (36-$t))}] + incr j + } + } + + proc adapt {delta first numchars} { + if {$first} { + set delta [expr {int($delta / 700)}] + } else { + set delta [expr {int($delta / 2)}] + } + incr delta [expr {int($delta / $numchars)}] + set divisions 0 + while {$delta > 455} { + set delta [expr {int($delta / 35)}] + incr divisions 36 + } + return [expr {$divisions + int(36 * $delta / ($delta + 38))}] + } + + proc encode {text} { + set base {} + set extenders {} + set splitstr [split $text ""] + foreach c $splitstr { + if {$c < "\u0080"} { + append base $c + } else { + lappend extenders $c + } + } + set deltas [insertionUnsort $splitstr [lsort $extenders]] + + set result {} + set bias 72 + set points 0 + if {$base ne ""} { + set baselen [string length $base] + foreach delta $deltas { + lappend result {*}[generateGeneralizedInteger $delta $bias] + set bias [adapt $delta [expr {!$points}] \ + [expr {$baselen + [incr points]}]] + } + return $base-[join $result ""] + } else { + foreach delta $deltas { + lappend result {*}[generateGeneralizedInteger $delta $bias] + set bias [adapt $delta [expr {!$points}] [incr points]] + } + return [join $result ""] + } + } + + + # Decoding + proc toNums {text} { + set retval {} + foreach c [split $text ""] { + scan $c "%c" ch + lappend retval $ch + } + return $retval + } + + proc toChars {nums} { + set chars {} + foreach char $nums { + append chars [format "%c" $char] + } + return $chars + } + + # 3.3 Generalized variable-length integers + proc decodeGeneralizedNumber {extended extpos bias errors} { + set result 0 + set w 1 + set j 0 + while true { + set c [lindex $extended $extpos] + incr extpos + if {[string length $c] == 0} { + if {$errors eq "strict"} { + error "incomplete punicode string" + } + return [list $extpos -1] + } + if {[string match {[A-Z]} $c]} { + scan $c "%c" char + set digit [expr {$char - 65}] + } elseif {[string match {[0-9]} $c]} { + scan $c "%c" char + # 0x30-26 + set digit [expr {$char - 22}] + } elseif {$errors eq "strict"} { + set pos [lindex $extended $extpos] + error "Invalid extended code point '$pos'" + } else { + return [list $extpos -1] + } + set t [T $j $bias] + set result [expr {$result + $digit * $w}] + if {$digit < $t} { + return [list $extpos $result] + } + set w [expr {$w * (36 - $t)}] + incr j + } + } + + # 3.2 Insertion unsort coding + proc insertionSort {base extended errors} { + set char 128 + set pos -1 + set bias 72 + set extpos 0 + while {$extpos < [llength $extended]} { + lassign [decodeGeneralizedNumber $extended $extpos $bias $errors]\ + newpos delta + if {$delta < 0} { + # There was an error in decoding. We can't continue because + # synchronization is lost. + return $base + } + set pos [expr {$pos + $delta + 1}] + set char [expr {$char + int($pos / ([llength $base] + 1))}] + if {$char > 1114111} { + if {$errors eq "strict"} { + error [format "Invalid character U+%x" $char] + } + set char 63 ;# "?" + } + set pos [expr {$pos % ([llength $base] + 1)}] + set base [linsert $base $pos $char] + set bias [adapt $delta [expr {$extpos == 0}] [llength $base]] + set extpos $newpos + } + return $base + } + + proc decode {text {errors "lax"}} { + set base {} + set pos [string last "-" $text] + if {$pos == -1} { + set extended [split [string toupper $text] ""] + } else { + set base [toNums [string range $text 0 [expr {$pos-1}]]] + set extended [split [string toupper [string range $text [expr {$pos+1}] end]] ""] + } + return [toChars [insertionSort $base $extended $errors]] + } +} -- cgit v0.12 From 99359a48d9f24edccccf5deb2745b83fc6f278d9 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 10 Sep 2012 11:00:59 +0000 Subject: Now, a working punycode engine --- library/http/cookiejar.tcl | 255 ++++++++++++++++++++++++--------------------- 1 file changed, 137 insertions(+), 118 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 605a621..ad56e31 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -397,120 +397,132 @@ package provide cookiejar $::http::cookiejar_version } # The implementation of the puncode encoder. This is based on the code on -# http://wiki.tcl.tk/10501 but with extensive modifications to be faster when -# encoding. - -# TODO: This gets some strings wrong! +# http://tools.ietf.org/html/rfc3492 (encoder) and http://wiki.tcl.tk/10501 +# (decoder) but with extensive modifications. namespace eval ::http::cookiejar_support::puny { namespace export encode decode variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""] + # Bootstring parameters for Punycode + variable base 36 + variable tmin 1 + variable tmax 26 + variable skew 38 + variable damp 700 + variable initial_bias 72 + variable initial_n 0x80 - # 3.2 Insertion unsort coding - proc insertionUnsort {splitstr extended} { - set oldchar 128 - set result {} - set oldindex -1 - foreach c $extended { - set index -1 - set pos -1 - set curlen 0 - foreach c2 $splitstr { - incr curlen [expr {$c2 < $c}] - } - scan $c "%c" char - set delta [expr {($curlen + 1) * ($char - $oldchar)}] - while true { - for {} {[incr pos] < [llength $splitstr]} {} { - set c2 [lindex $splitstr $pos] - if {$c2 eq $c} { - incr index - break - } elseif {$c2 < $c} { - incr index + proc adapt {delta first numchars} { + variable base + variable tmin + variable tmax + variable damp + variable skew + + set delta [expr {$delta / ($first ? $damp : 2)}] + incr delta [expr {$delta / $numchars}] + set k 0 + while {$delta > ($base - $tmin) * $tmax / 2} { + set delta [expr {$delta / ($base-$tmin)}] + incr k $base + } + return [expr {$k + ($base-$tmin+1) * $delta / ($delta+$skew)}] + } + + # Main encode function + proc encode {input {case ""}} { + variable digits + variable tmin + variable tmax + variable base + variable initial_n + variable initial_bias + + set in [split $input ""] + set output {} + + # Initialize the state: + set n $initial_n + set delta 0 + set bias $initial_bias + + # Handle the basic code points: + foreach ch $in { + if {$ch < "\u0080"} { + if {$case ne ""} { + if {$case} { + append output [string toupper $ch] + } else { + append output [string tolower $ch] } + } else { + append output $ch } - if {$pos == [llength $splitstr]} { - set pos -1 - break - } - lappend result [expr {$delta + $index - $oldindex - 1}] - set oldindex $index - set delta 0 } - set oldchar $char } - return $result - } - # Punycode parameters: tmin = 1, tmax = 26, base = 36 - proc T {j bias} { - return [expr {min(max(36 * ($j + 1) - $bias, 1), 26)}] - } + set h [set b [string length $output]] - # 3.3 Generalized variable-length integers - proc generateGeneralizedInteger {N bias} { - variable digits - set result {} - set j 0 - while true { - set t [T $j $bias] - if {$N < $t} { - return [lappend result [lindex $digits $N]] - } - lappend result [lindex $digits [expr {$t + (($N-$t) % (36-$t))}]] - set N [expr {int(($N-$t) / (36-$t))}] - incr j - } - } + # h is the number of code points that have been handled, b is the + # number of basic code points. - proc adapt {delta first numchars} { - if {$first} { - set delta [expr {int($delta / 700)}] - } else { - set delta [expr {int($delta / 2)}] - } - incr delta [expr {int($delta / $numchars)}] - set divisions 0 - while {$delta > 455} { - set delta [expr {int($delta / 35)}] - incr divisions 36 + if {$b} { + append output "-" } - return [expr {$divisions + int(36 * $delta / ($delta + 38))}] - } - proc encode {text} { - set base {} - set extenders {} - set splitstr [split $text ""] - foreach c $splitstr { - if {$c < "\u0080"} { - append base $c - } else { - lappend extenders $c + # Main encoding loop: + + while {$h < [llength $in]} { + # All non-basic code points < n have been handled already. Find + # the next larger one: + + for {set m inf; set j 0} {$j < [llength $in]} {incr j} { + scan [lindex $in $j] "%c" ch + if {$ch >= $n && $ch < $m} { + set m $ch + } } - } - set deltas [insertionUnsort $splitstr [lsort $extenders]] - set result {} - set bias 72 - set points 0 - if {$base ne ""} { - set baselen [string length $base] - foreach delta $deltas { - lappend result {*}[generateGeneralizedInteger $delta $bias] - set bias [adapt $delta [expr {!$points}] \ - [expr {$baselen + [incr points]}]] + # Increase delta enough to advance the decoder's state to + # , but guard against overflow: + + if {$m-$n > (0xffffffff-$delta)/($h+1)} { + throw {PUNYCODE OVERFLOW} "overflow in delta computation" } - return $base-[join $result ""] - } else { - foreach delta $deltas { - lappend result {*}[generateGeneralizedInteger $delta $bias] - set bias [adapt $delta [expr {!$points}] [incr points]] + incr delta [expr {($m-$n) * ($h+1)}] + set n $m + + for {set j 0} {$j < [llength $in]} {incr j} { + scan [lindex $in $j] "%c" ch + if {$ch < $n && ([incr delta] & 0xffffffff) == 0} { + throw {PUNYCODE OVERFLOW} "overflow in delta computation" + } + + if {$ch == $n} { + # Represent delta as a generalized variable-length + # integer: + + for {set q $delta; set k $base} true {incr k $base} { + set t [expr {min(max($k-$bias,$tmin),$tmax)}] + if {$q < $t} break + append output \ + [lindex $digits [expr {$t + ($q-$t)%($base-$t)}]] + set q [expr {($q-$t) / ($base-$t)}] + } + + append output [lindex $digits $q] + set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]] + set delta 0 + incr h + } } - return [join $result ""] + + incr delta + incr n } + + return $output } @@ -533,7 +545,11 @@ namespace eval ::http::cookiejar_support::puny { } # 3.3 Generalized variable-length integers - proc decodeGeneralizedNumber {extended extpos bias errors} { + proc decodeGeneralizedInteger {extended extpos bias errors} { + variable tmin + variable tmax + variable base + set result 0 set w 1 set j 0 @@ -546,68 +562,71 @@ namespace eval ::http::cookiejar_support::puny { } return [list $extpos -1] } + scan $c "%c" char if {[string match {[A-Z]} $c]} { - scan $c "%c" char - set digit [expr {$char - 65}] + set digit [expr {$char - 0x41}]; # A=0,Z=25 + } elseif {[string match {[a-z]} $c]} { + set digit [expr {$char - 0x61}]; # a=0,z=25 } elseif {[string match {[0-9]} $c]} { - scan $c "%c" char - # 0x30-26 - set digit [expr {$char - 22}] + set digit [expr {$char - 0x30 + 26}]; # 0=26,9=35 } elseif {$errors eq "strict"} { set pos [lindex $extended $extpos] error "Invalid extended code point '$pos'" } else { return [list $extpos -1] } - set t [T $j $bias] + set t [expr {min(max($base*($j + 1) - $bias, $tmin), $tmax)}] set result [expr {$result + $digit * $w}] if {$digit < $t} { return [list $extpos $result] } - set w [expr {$w * (36 - $t)}] + set w [expr {$w * ($base - $t)}] incr j } } # 3.2 Insertion unsort coding - proc insertionSort {base extended errors} { - set char 128 + proc insertionSort {buffer extended errors} { + variable initial_bias + variable initial_n + + set char $initial_n set pos -1 - set bias 72 + set bias $initial_bias set extpos 0 while {$extpos < [llength $extended]} { - lassign [decodeGeneralizedNumber $extended $extpos $bias $errors]\ + lassign [decodeGeneralizedInteger $extended $extpos $bias $errors]\ newpos delta if {$delta < 0} { # There was an error in decoding. We can't continue because # synchronization is lost. - return $base + return $buffer } - set pos [expr {$pos + $delta + 1}] - set char [expr {$char + int($pos / ([llength $base] + 1))}] + incr pos [expr {$delta + 1}] + set char [expr {$char + $pos / ([llength $buffer] + 1)}] if {$char > 1114111} { if {$errors eq "strict"} { error [format "Invalid character U+%x" $char] } set char 63 ;# "?" } - set pos [expr {$pos % ([llength $base] + 1)}] - set base [linsert $base $pos $char] - set bias [adapt $delta [expr {$extpos == 0}] [llength $base]] + set pos [expr {$pos % ([llength $buffer] + 1)}] + set buffer [linsert $buffer $pos $char] + set bias [adapt $delta [expr {$extpos == 0}] [llength $buffer]] set extpos $newpos } - return $base + return $buffer } proc decode {text {errors "lax"}} { - set base {} + set baseline {} set pos [string last "-" $text] if {$pos == -1} { - set extended [split [string toupper $text] ""] + set extended $text } else { - set base [toNums [string range $text 0 [expr {$pos-1}]]] - set extended [split [string toupper [string range $text [expr {$pos+1}] end]] ""] + set baseline [toNums [string range $text 0 [expr {$pos-1}]]] + set extended [string range $text [expr {$pos+1}] end] } - return [toChars [insertionSort $base $extended $errors]] + return [toChars [insertionSort $baseline [split $extended ""] $errors]] } } -- cgit v0.12 From 79180834a7e0282987b0c92bcff98ac47d60b1b1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Sep 2012 13:24:22 +0000 Subject: fix running package-tests on Windows, correct TCLSH_PROG in this case --- win/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/Makefile.in b/win/Makefile.in index 392bd7a..4dbdbbd 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -786,7 +786,7 @@ test-packages: tcltest packages pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ echo "Testing package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) "LD_LIBRARY_PATH=$$builddir:${LD_LIBRARY_PATH}" "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" "TCLLIBPATH=$$builddir/pkgs" test "TCLSH_PROG=$$builddir/tcltest"; ) \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) "LD_LIBRARY_PATH=$$builddir:${LD_LIBRARY_PATH}" "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" "TCLLIBPATH=$$builddir/pkgs" test "TCLSH_PROG=$$builddir/${TCLSH}"; ) \ fi; \ fi; \ done; \ -- cgit v0.12 From 6f1a0f1c60d7c85d2e331d67a431a9306bab8c48 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 10 Sep 2012 21:24:34 +0000 Subject: loading of restricted domain list now believed to work --- library/http/cookiejar.tcl | 171 ++++++++++++++++++++------------ library/http/effective_tld_names.txt.gz | Bin 0 -> 32891 bytes 2 files changed, 110 insertions(+), 61 deletions(-) create mode 100644 library/http/effective_tld_names.txt.gz diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index ad56e31..be7b37f 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -7,16 +7,20 @@ package require http 2.7;# FIXME: JUST DURING DEVELOPMENT #package require Tcl 8.6 #package require http 2.8.4 package require sqlite3 +#package require zlib # Configuration for the cookiejar package namespace eval ::http { # TODO: is this the _right_ list of domains to use? variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 + variable cookiejar_domainfile \ + [file join [file dirname [info script]] effective_tld_names.txt] # The list is directed to from http://publicsuffix.org/list/ variable cookiejar_version 0.1 variable cookiejar_loglevel info variable cookiejar_vacuumtrigger 200 + variable cookiejar_offline false # This is the class that we are creating ::oo::class create cookiejar @@ -53,7 +57,7 @@ namespace eval ::http { clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1 } proc log {level msg} { - upvar 0 ::http::cookiejar_loglevel loglevel + namespace upvar ::http cookiejar_loglevel loglevel set who [uplevel 1 self] set map {debug 0 info 1 warn 2 error 3} if {[string map $map $level] >= [string map $map $loglevel]} { @@ -71,6 +75,17 @@ namespace eval ::http { } return [join $parts .] } + proc IDNAdecode str { + set parts {} + # Split term from RFC 3490, Sec 3.1 + foreach part [split $str "\u002E\u3002\uFF0E\uFF61"] { + if {[string match "xn--*" $part]} { + set part [puny::decode [string range $part 4 end]] + } + lappend parts $part + } + return [join $parts .] + } } } @@ -80,7 +95,7 @@ package provide cookiejar $::http::cookiejar_version # The implementation of the cookiejar package ::oo::define ::http::cookiejar { self method loglevel {{level "\u0000\u0000"}} { - upvar 0 ::http::cookiejar_loglevel loglevel + namespace upvar ::http cookiejar_loglevel loglevel if {$level in {debug info warn error}} { set loglevel $level } elseif {$level ne "\u0000\u0000"} { @@ -165,70 +180,105 @@ package provide cookiejar $::http::cookiejar_version --;# forbiddenSuper table). CREATE TABLE IF NOT EXISTS domains ( domain TEXT PRIMARY KEY NOT NULL, - forbidden INTEGER NOT NULL) + forbidden INTEGER NOT NULL); --;# Domains that may not have a cookie defined for direct child --;# domains of them. CREATE TABLE IF NOT EXISTS forbiddenSuper ( domain TEXT PRIMARY KEY); } - if {$path ne ""} { - if {![db exists { - SELECT 1 FROM sqlite_master - WHERE type='table' AND name='domains' - }] && ![db exists { - SELECT 1 FROM domains - }]} then { - my InitDomainList - } + if {$path ne "" && ![db exists { + SELECT 1 FROM domains + }]} then { + my InitDomainList } } method InitDomainList {} { - # TODO: Handle IDNs (but Tcl overall gets that wrong at the moment...) - variable ::http::cookiejar_domainlist - log debug "loading domain list from $cookiejar_domainlist" - set tok [http::geturl $cookiejar_domainlist] + namespace upvar ::http \ + cookiejar_domainlist url \ + cookiejar_domainfile filename \ + cookiejar_offline offline + if {!$offline} { + log debug "loading domain list from $url" + set tok [::http::geturl $url] + try { + if {[::http::ncode $tok] == 200} { + my InstallDomainData [::http::data $tok] + return + } else { + log error "failed to fetch list of forbidden cookie domains from ${url}: [::http::error $tok]" + log warn "attempting to fall back to built in version" + } + } finally { + ::http::cleanup $tok + } + } + log debug "loading domain list from $filename" try { - if {[http::ncode $tok] == 200} { - db transaction { - foreach line [split [http::data $tok] \n] { - if {[string trim $line] eq ""} continue - if {[string match //* $line]} continue - if {[string match !* $line]} { - set line [string range $line 1 end] - set idna [IDNAencode $line] - db eval { - INSERT INTO domains (domain, forbidden) - VALUES ($line, 0); - INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($idna, 0); - } - } else { - if {[string match {\*.*} $line]} { - set line [string range $line 2 end] - db eval { - INSERT INTO forbiddenSuper (domain) - VALUES ($line); - INSERT OR REPLACE INTO forbiddenSuper (domain) - VALUES ($idna); - } - } - set idna [IDNAencode $line] - db eval { - INSERT INTO domains (domain, forbidden) - VALUES ($line, 1); - INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($idna, 1); - } + set f [open $filename] + try { + if {[string match *.gz $filename]} { + zlib push gunzip $f + } + fconfigure $f -encoding utf-8 + my InstallDomainData [read $f] + } finally { + close $f + } + } on error msg { + log error "failed to read list of forbidden cookie domains from ${filename}: $msg" + return -code error $msg + } + } + + method InstallDomainData {data} { + set n [db total_changes] + db transaction { + foreach line [split $data "\n"] { + if {[string trim $line] eq ""} continue + if {[string match //* $line]} continue + if {[string match !* $line]} { + set line [string range $line 1 end] + set idna [IDNAencode $line] + db eval { + INSERT INTO domains (domain, forbidden) + VALUES ($line, 0); + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 0); + } + } else { + if {[string match {\*.*} $line]} { + set line [string range $line 2 end] + db eval { + INSERT INTO forbiddenSuper (domain) + VALUES ($line); + INSERT OR REPLACE INTO forbiddenSuper (domain) + VALUES ($idna); } } + set idna [IDNAencode $line] + db eval { + INSERT INTO domains (domain, forbidden) + VALUES ($line, 1); + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 1); + } } - } else { - log error "failed to fetch list of forbidden cookie domains from $cookiejar_domainlist" } - } finally { - http::cleanup $tok + } + set n [expr {[db total_changes] - $n}] + log debug "processed $n inserts generated from domain list" + } + + # This forces the rebuild of the domain data, loading it from + method forceLoadDomainData {} { + db transaction { + db eval { + DELETE FROM domains; + DELETE FROM forbiddenSuper; + } + my InitDomainList } } @@ -367,7 +417,7 @@ package provide cookiejar $::http::cookiejar_version } method PurgeCookies {} { - upvar 0 ::http::cookiejar_vacuumtrigger vacuumtrigger + namespace upvar 0 ::http cookiejar_vacuumtrigger vacuumtrigger set aid [after 60000 [namespace current]::my PurgeCookies] set now [clock seconds] log debug "purging cookies that expired before [clock format $now]" @@ -488,7 +538,7 @@ namespace eval ::http::cookiejar_support::puny { # , but guard against overflow: if {$m-$n > (0xffffffff-$delta)/($h+1)} { - throw {PUNYCODE OVERFLOW} "overflow in delta computation" + error "overflow in delta computation" } incr delta [expr {($m-$n) * ($h+1)}] set n $m @@ -496,7 +546,7 @@ namespace eval ::http::cookiejar_support::puny { for {set j 0} {$j < [llength $in]} {incr j} { scan [lindex $in $j] "%c" ch if {$ch < $n && ([incr delta] & 0xffffffff) == 0} { - throw {PUNYCODE OVERFLOW} "overflow in delta computation" + error "overflow in delta computation" } if {$ch == $n} { @@ -525,7 +575,6 @@ namespace eval ::http::cookiejar_support::puny { return $output } - # Decoding proc toNums {text} { set retval {} @@ -590,7 +639,7 @@ namespace eval ::http::cookiejar_support::puny { variable initial_bias variable initial_n - set char $initial_n + set n $initial_n set pos -1 set bias $initial_bias set extpos 0 @@ -603,15 +652,15 @@ namespace eval ::http::cookiejar_support::puny { return $buffer } incr pos [expr {$delta + 1}] - set char [expr {$char + $pos / ([llength $buffer] + 1)}] - if {$char > 1114111} { + incr n [expr {$pos / ([llength $buffer] + 1)}] + if {$n > 1114111} { if {$errors eq "strict"} { - error [format "Invalid character U+%x" $char] + error [format "Invalid character U+%06x" $n] } - set char 63 ;# "?" + set n 63 ;# "?" } set pos [expr {$pos % ([llength $buffer] + 1)}] - set buffer [linsert $buffer $pos $char] + set buffer [linsert $buffer $pos $n] set bias [adapt $delta [expr {$extpos == 0}] [llength $buffer]] set extpos $newpos } diff --git a/library/http/effective_tld_names.txt.gz b/library/http/effective_tld_names.txt.gz new file mode 100644 index 0000000..a799d16 Binary files /dev/null and b/library/http/effective_tld_names.txt.gz differ -- cgit v0.12 From 52d39094e48a6c1b184d207d1e191266eaf1e0d0 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 11 Sep 2012 10:37:10 +0000 Subject: packing the code tighter, doing more explanatory comments --- library/http/cookiejar.tcl | 384 ++++++++++++++++++++++++++------------------- 1 file changed, 222 insertions(+), 162 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index be7b37f..c1e837c 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -1,5 +1,12 @@ -# Cookie Jar package. - +# cookiejar.tcl -- +# +# Implementation of an HTTP cookie storage engine using SQLite. The +# implementation is done as a TclOO class, and includes a punycode +# encoder and decoder (though only the encoder is currently used). +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + # Dependencies package require Tcl 8.5;# FIXME: JUST DURING DEVELOPMENT package require TclOO;# FIXME: JUST DURING DEVELOPMENT @@ -7,20 +14,26 @@ package require http 2.7;# FIXME: JUST DURING DEVELOPMENT #package require Tcl 8.6 #package require http 2.8.4 package require sqlite3 -#package require zlib + +# +# Configuration for the cookiejar package, plus basic support procedures. +# -# Configuration for the cookiejar package namespace eval ::http { + # Keep this in sync with pkgIndex.tcl and with the install directories in + # Makefiles + variable cookiejar_version 0.1 + # TODO: is this the _right_ list of domains to use? variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 variable cookiejar_domainfile \ [file join [file dirname [info script]] effective_tld_names.txt] # The list is directed to from http://publicsuffix.org/list/ - variable cookiejar_version 0.1 variable cookiejar_loglevel info variable cookiejar_vacuumtrigger 200 variable cookiejar_offline false + variable cookiejar_purgeinterval 60000 # This is the class that we are creating ::oo::class create cookiejar @@ -30,10 +43,12 @@ namespace eval ::http { namespace export * proc locn {secure domain path {key ""}} { if {$key eq ""} { - format "%s://%s%s" [expr {$secure?"https":"http"}] $domain $path + format "%s://%s%s" [expr {$secure?"https":"http"}] \ + [IDNAencode $domain] $path } else { format "%s://%s%s?%s" \ - [expr {$secure?"https":"http"}] $domain $path $key + [expr {$secure?"https":"http"}] [IDNAencode $domain] \ + $path $key } } proc splitDomain domain { @@ -107,6 +122,7 @@ package provide cookiejar $::http::cookiejar_version variable aid deletions constructor {{path ""}} { namespace import ::http::cookiejar_support::* + namespace upvar ::http cookiejar_purgeinterval purgeinterval if {$path eq ""} { sqlite3 [namespace current]::db :memory: @@ -161,32 +177,31 @@ package provide cookiejar $::http::cookiejar_version SELECT id, domain, path, key, value, originonly, secure, 0 AS persistent FROM sessionCookies; - } - - db eval { - SELECT COUNT(*) AS cookieCount FROM persistentCookies - } - if {[info exist cookieCount] && $cookieCount} { - log info "loaded cookie store from $path with $cookieCount entries" - } - set aid [after 60000 [namespace current]::my PurgeCookies] - - # TODO: domain list refresh policy - db eval { --;# Encoded domain permission policy; if forbidden is 1, no --;# cookie may be ever set for the domain, and if forbidden is 0, --;# cookies *may* be created for the domain (overriding the --;# forbiddenSuper table). + --;# Deletion policy: normally not modified. CREATE TABLE IF NOT EXISTS domains ( domain TEXT PRIMARY KEY NOT NULL, forbidden INTEGER NOT NULL); --;# Domains that may not have a cookie defined for direct child --;# domains of them. + --;# Deletion policy: normally not modified. CREATE TABLE IF NOT EXISTS forbiddenSuper ( domain TEXT PRIMARY KEY); } + + db eval { + SELECT COUNT(*) AS cookieCount FROM persistentCookies + } + log info "loaded cookie store from $path with $cookieCount entries" + + set aid [after $purgeinterval [namespace current]::my PurgeCookies] + + # TODO: domain list refresh policy if {$path ne "" && ![db exists { SELECT 1 FROM domains }]} then { @@ -236,35 +251,57 @@ package provide cookiejar $::http::cookiejar_version set n [db total_changes] db transaction { foreach line [split $data "\n"] { - if {[string trim $line] eq ""} continue - if {[string match //* $line]} continue - if {[string match !* $line]} { + if {[string trim $line] eq ""} { + continue + } elseif {[string match //* $line]} { + continue + } elseif {[string match !* $line]} { set line [string range $line 1 end] set idna [IDNAencode $line] + set utf [IDNAdecode $line] db eval { - INSERT INTO domains (domain, forbidden) - VALUES ($line, 0); INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($idna, 0); + VALUES ($utf, 0); + } + if {$idna ne $utf} { + db eval { + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 0); + } } } else { if {[string match {\*.*} $line]} { set line [string range $line 2 end] + set idna [IDNAencode $line] + set utf [IDNAdecode $line] db eval { - INSERT INTO forbiddenSuper (domain) - VALUES ($line); INSERT OR REPLACE INTO forbiddenSuper (domain) - VALUES ($idna); + VALUES ($utf); + } + if {$idna ne $utf} { + db eval { + INSERT OR REPLACE INTO forbiddenSuper (domain) + VALUES ($idna); + } } + } else { + set idna [IDNAencode $line] + set utf [IDNAdecode $line] } - set idna [IDNAencode $line] db eval { - INSERT INTO domains (domain, forbidden) - VALUES ($line, 1); INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($idna, 1); + VALUES ($utf, 1); + } + if {$idna ne $utf} { + db eval { + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 1); + } } } + if {$utf ne [IDNAdecode $idna]} { + log warn "mismatch in IDNA handling for $idna" + } } } set n [expr {[db total_changes] - $n}] @@ -313,13 +350,15 @@ package provide cookiejar $::http::cookiejar_version method getCookies {proto host path} { set result {} set paths [splitPath $path] - set domains [splitDomain $host] + set domains [splitDomain [IDNAencode $host]] set secure [string equal -nocase $proto "https"] # Open question: how to move these manipulations into the database # engine (if that's where they *should* be). # Suggestion from kbk: - #LENGTH(theColumn) <= LENGTH($queryStr) AND SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr + #LENGTH(theColumn) <= LENGTH($queryStr) AND + #SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr if {[regexp {[^0-9.]} $host]} { + # Ugh, it's a numeric domain! Restrict it... db transaction { foreach domain $domains { foreach p $paths { @@ -417,8 +456,10 @@ package provide cookiejar $::http::cookiejar_version } method PurgeCookies {} { - namespace upvar 0 ::http cookiejar_vacuumtrigger vacuumtrigger - set aid [after 60000 [namespace current]::my PurgeCookies] + namespace upvar ::http \ + cookiejar_vacuumtrigger trigger \ + cookiejar_purgeinterval interval + set aid [after $interval [namespace current]::my PurgeCookies] set now [clock seconds] log debug "purging cookies that expired before [clock format $now]" db transaction { @@ -432,7 +473,7 @@ package provide cookiejar $::http::cookiejar_version # Once we've deleted a fair bit, vacuum the database. Must be done # outside a transaction. - if {$deletions > $vacuumtrigger} { + if {$deletions > $trigger} { set deletions 0 log debug "vacuuming cookie database" catch { @@ -444,9 +485,44 @@ package provide cookiejar $::http::cookiejar_version } forward Database db + + method lookup {{host ""} {key ""}} { + set host [IDNAencode $host] + db transaction { + if {$host eq ""} { + set result {} + db eval { + SELECT DISTINCT domain FROM cookies + ORDER BY domain + } { + lappend result [IDNAdecode $domain] + } + return $result + } elseif {$key eq ""} { + set result {} + db eval { + SELECT DISTINCT key FROM cookies + WHERE domain = $host + ORDER BY key + } { + lappend result $key + } + return $result + } else { + db eval { + SELECT value FROM cookies + WHERE domain = $host AND key = $key + LIMIT 1 + } { + return $value + } + return -code error "no such key for that host" + } + } + } } -# The implementation of the puncode encoder. This is based on the code on +# The implementation of the punycode encoder. This is based on the code on # http://tools.ietf.org/html/rfc3492 (encoder) and http://wiki.tcl.tk/10501 # (decoder) but with extensive modifications. @@ -463,6 +539,10 @@ namespace eval ::http::cookiejar_support::puny { variable initial_bias 72 variable initial_n 0x80 + variable maxcodepoint 0xFFFF ;# 0x10FFFF would be correct, except Tcl + # can't handle non-BMP characters right now + # anyway. + proc adapt {delta first numchars} { variable base variable tmin @@ -489,7 +569,11 @@ namespace eval ::http::cookiejar_support::puny { variable initial_n variable initial_bias - set in [split $input ""] + set in {} + foreach char [set input [split $input ""]] { + scan $char "%c" ch + lappend in $ch + } set output {} # Initialize the state: @@ -498,37 +582,35 @@ namespace eval ::http::cookiejar_support::puny { set bias $initial_bias # Handle the basic code points: - foreach ch $in { + foreach ch $input { if {$ch < "\u0080"} { - if {$case ne ""} { - if {$case} { - append output [string toupper $ch] - } else { - append output [string tolower $ch] - } - } else { + if {$case eq ""} { append output $ch + } elseif {$case} { + append output [string toupper $ch] + } else { + append output [string tolower $ch] } } } - set h [set b [string length $output]] + set b [string length $output] # h is the number of code points that have been handled, b is the # number of basic code points. - if {$b} { + if {$b > 0} { append output "-" } # Main encoding loop: - while {$h < [llength $in]} { + for {set h $b} {$h < [llength $in]} {incr delta; incr n} { # All non-basic code points < n have been handled already. Find # the next larger one: - for {set m inf; set j 0} {$j < [llength $in]} {incr j} { - scan [lindex $in $j] "%c" ch + set m inf + foreach ch $in { if {$ch >= $n && $ch < $m} { set m $ch } @@ -538,144 +620,122 @@ namespace eval ::http::cookiejar_support::puny { # , but guard against overflow: if {$m-$n > (0xffffffff-$delta)/($h+1)} { - error "overflow in delta computation" + throw {PUNYCODE OVERFLOW} "overflow in delta computation" } incr delta [expr {($m-$n) * ($h+1)}] set n $m - for {set j 0} {$j < [llength $in]} {incr j} { - scan [lindex $in $j] "%c" ch + foreach ch $in { if {$ch < $n && ([incr delta] & 0xffffffff) == 0} { - error "overflow in delta computation" + throw {PUNYCODE OVERFLOW} "overflow in delta computation" + } + + if {$ch != $n} { + continue } - if {$ch == $n} { - # Represent delta as a generalized variable-length - # integer: + # Represent delta as a generalized variable-length integer: - for {set q $delta; set k $base} true {incr k $base} { - set t [expr {min(max($k-$bias,$tmin),$tmax)}] - if {$q < $t} break - append output \ - [lindex $digits [expr {$t + ($q-$t)%($base-$t)}]] - set q [expr {($q-$t) / ($base-$t)}] + for {set q $delta; set k $base} true {incr k $base} { + set t [expr {min(max($k-$bias, $tmin), $tmax)}] + if {$q < $t} { + break } - - append output [lindex $digits $q] - set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]] - set delta 0 - incr h + append output \ + [lindex $digits [expr {$t + ($q-$t)%($base-$t)}]] + set q [expr {($q-$t) / ($base-$t)}] } - } - incr delta - incr n + append output [lindex $digits $q] + set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]] + set delta 0 + incr h + } } return $output } - # Decoding - proc toNums {text} { - set retval {} - foreach c [split $text ""] { - scan $c "%c" ch - lappend retval $ch - } - return $retval - } + # Main decode function + proc decode {text {errors "lax"}} { + namespace upvar ::http::cookiejar_support::puny \ + tmin tmin tmax tmax base base initial_bias initial_bias \ + initial_n initial_n maxcodepoint maxcodepoint - proc toChars {nums} { - set chars {} - foreach char $nums { - append chars [format "%c" $char] - } - return $chars - } + set n $initial_n + set pos -1 + set bias $initial_bias + set buffer [set chars {}] + set pos [string last "-" $text] + if {$pos >= 0} { + set buffer [split [string range $text 0 [expr {$pos-1}]] ""] + set text [string range $text [expr {$pos+1}] end] + } + set points [split $text ""] + set first true + + for {set extpos 0} {$extpos < [llength $points]} {} { + # Extract the delta, which is the encoding of the character and + # where to insert it. + + set delta 0 + set w 1 + for {set j 1} true {incr j} { + scan [set c [lindex $points $extpos]] "%c" char + if {[string match {[A-Z]} $c]} { + set digit [expr {$char - 0x41}]; # A=0,Z=25 + } elseif {[string match {[a-z]} $c]} { + set digit [expr {$char - 0x61}]; # a=0,z=25 + } elseif {[string match {[0-9]} $c]} { + set digit [expr {$char - 0x30 + 26}]; # 0=26,9=35 + } else { + if {$errors eq "strict"} { + throw {PUNYCODE INVALID} \ + "invalid extended code point '$c'" + } + # There was an error in decoding. We can't continue + # because synchronization is lost. + return [join $buffer ""] + } - # 3.3 Generalized variable-length integers - proc decodeGeneralizedInteger {extended extpos bias errors} { - variable tmin - variable tmax - variable base + incr extpos + set t [expr {min(max($base*$j - $bias, $tmin), $tmax)}] + incr delta [expr {$digit * $w}] + if {$digit < $t} { + break + } + set w [expr {$w * ($base - $t)}] - set result 0 - set w 1 - set j 0 - while true { - set c [lindex $extended $extpos] - incr extpos - if {[string length $c] == 0} { - if {$errors eq "strict"} { - error "incomplete punicode string" + if {$extpos >= [llength $points]} { + if {$errors eq "strict"} { + throw {PUNYCODE PARTIAL} "incomplete punycode string" + } + # There was an error in decoding. We can't continue + # because synchronization is lost. + return [join $buffer ""] } - return [list $extpos -1] - } - scan $c "%c" char - if {[string match {[A-Z]} $c]} { - set digit [expr {$char - 0x41}]; # A=0,Z=25 - } elseif {[string match {[a-z]} $c]} { - set digit [expr {$char - 0x61}]; # a=0,z=25 - } elseif {[string match {[0-9]} $c]} { - set digit [expr {$char - 0x30 + 26}]; # 0=26,9=35 - } elseif {$errors eq "strict"} { - set pos [lindex $extended $extpos] - error "Invalid extended code point '$pos'" - } else { - return [list $extpos -1] - } - set t [expr {min(max($base*($j + 1) - $bias, $tmin), $tmax)}] - set result [expr {$result + $digit * $w}] - if {$digit < $t} { - return [list $extpos $result] } - set w [expr {$w * ($base - $t)}] - incr j - } - } - # 3.2 Insertion unsort coding - proc insertionSort {buffer extended errors} { - variable initial_bias - variable initial_n + # Now we've got the delta, we can generate the character and + # insert it. - set n $initial_n - set pos -1 - set bias $initial_bias - set extpos 0 - while {$extpos < [llength $extended]} { - lassign [decodeGeneralizedInteger $extended $extpos $bias $errors]\ - newpos delta - if {$delta < 0} { - # There was an error in decoding. We can't continue because - # synchronization is lost. - return $buffer - } - incr pos [expr {$delta + 1}] - incr n [expr {$pos / ([llength $buffer] + 1)}] - if {$n > 1114111} { + incr n [expr {[incr pos [expr {$delta+1}]]/([llength $buffer]+1)}] + if {$n > $maxcodepoint} { if {$errors eq "strict"} { - error [format "Invalid character U+%06x" $n] + if {$n < 0x10ffff} { + throw {PUNYCODE NON_BMP} \ + [format "unsupported character U+%06x" $n] + } + throw {PUNYCODE NON_UNICODE} "bad codepoint $n" } set n 63 ;# "?" + set extpos inf; # We're blowing up anyway... } set pos [expr {$pos % ([llength $buffer] + 1)}] - set buffer [linsert $buffer $pos $n] - set bias [adapt $delta [expr {$extpos == 0}] [llength $buffer]] - set extpos $newpos - } - return $buffer - } - - proc decode {text {errors "lax"}} { - set baseline {} - set pos [string last "-" $text] - if {$pos == -1} { - set extended $text - } else { - set baseline [toNums [string range $text 0 [expr {$pos-1}]]] - set extended [string range $text [expr {$pos+1}] end] + set buffer [linsert $buffer $pos [format "%c" $n]] + set bias [adapt $delta $first [llength $buffer]] + set first false } - return [toChars [insertionSort $baseline [split $extended ""] $errors]] + return [join $buffer ""] } } -- cgit v0.12 From a574ca01f5d82001d8d6663cd795ab9ad9c4abde Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Sep 2012 14:07:27 +0000 Subject: 3564735 Protect against mem corruption when var resolvers misbehave. --- generic/tclInt.h | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 53a88d6..6c6e664 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -801,13 +801,17 @@ typedef struct VarInHash { #define TclSetVarNamespaceVar(varPtr) \ if (!TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags |= VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount++;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount++;\ + }\ } #define TclClearVarNamespaceVar(varPtr) \ if (TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount--;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount--;\ + }\ } /* -- cgit v0.12 From e44afcc1bcc88271f5d95b7c48320455689a3ae3 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 12 Sep 2012 17:42:59 +0000 Subject: tip#404 file locale mcset: mc(fl)(m)set backport from 8.6 --- ChangeLog | 8 ++++ doc/msgcat.n | 91 ++++++++++++++++++++++++++++++++++++--------- library/msgcat/msgcat.tcl | 82 ++++++++++++++++++++++++++++++++++++++-- library/msgcat/pkgIndex.tcl | 2 +- tests/msgcat.test | 44 +++++++++++++++++++++- 5 files changed, 203 insertions(+), 24 deletions(-) diff --git a/ChangeLog b/ChangeLog index b0fed83..4d2d296 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-09-07 Harald Oehlmann + + IMPLEMENTATION OF TIP#404. + + * library/msgcat.tcl: [FRQ 3544988] (Backport from tcl8.6): add commands + [mcflset] and [mcflmset] to set mc entries with implicit message file + locale. Package version is now 1.5.0. + 2012-09-07 Alexandre Ferrieux * unix/tclUnixNotfy.c Backport of 2008-12-12 8.6 commit: Fix diff --git a/doc/msgcat.n b/doc/msgcat.n index c2c0abd..af6be7f 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -13,7 +13,7 @@ msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.5\fR .sp -\fBpackage require msgcat 1.4.5\fR +\fBpackage require msgcat 1.5.0\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp @@ -29,6 +29,12 @@ msgcat \- Tcl message catalog .sp \fB::msgcat::mcmset \fIlocale src-trans-list\fR .sp +.VS "TIP 404" +\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? +.sp +\fB::msgcat::mcflmset \fIsrc-trans-list\fR +.VE "TIP 404" +.sp \fB::msgcat::mcunknown \fIlocale src-string\fR .BE .SH DESCRIPTION @@ -49,6 +55,7 @@ wishes to be enabled for multi-lingual applications. .SH COMMANDS .TP \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? +. Returns a translation of \fIsrc-string\fR according to the user's current locale. If additional arguments past \fIsrc-string\fR are given, the \fBformat\fR command is used to substitute the @@ -71,12 +78,14 @@ later simply by defining new message catalog entries. .RE .TP \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? +. Given several source strings, \fB::msgcat::mcmax\fR returns the length of the longest translated string. This is useful when designing localized GUIs, which may require that all buttons, for example, be a fixed width (which will be the width of the widest button). .TP -\fB::msgcat::mclocale \fR?\fInewLocale\fR? +\fB::msgcat::mclocale \fR?\fInewLocale\fR? +. This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale is set to \fInewLocale\fR. msgcat stores and compares the locale in a @@ -86,6 +95,7 @@ the user's environment. See \fBLOCALE SPECIFICATION\fR below for a description of the locale string format. .TP \fB::msgcat::mcpreferences\fR +. Returns an ordered list of the locales preferred by the user, based on the user's language specification. The list is ordered from most specific to least @@ -93,11 +103,10 @@ preference. The list is derived from the current locale set in msgcat by \fB::msgcat::mclocale\fR, and cannot be set independently. For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR -.VS 1.4 returns \fB{en_US_funky en_US en {}}\fR. -.VE 1.4 .TP \fB::msgcat::mcload \fIdirname\fR +. Searches the specified directory for files that match the language specifications returned by \fB::msgcat::mcpreferences\fR (note that these are all lowercase), extended by the file extension @@ -111,12 +120,14 @@ evaluation. The number of message files which matched the specification and were loaded is returned. .TP \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? +. Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the specified \fIlocale\fR and the current namespace. If \fItranslate-string\fR is not specified, \fIsrc-string\fR is used for both. The function returns \fItranslate-string\fR. .TP \fB::msgcat::mcmset \fIlocale src-trans-list\fR +. Sets the translation for multiple source strings in \fIsrc-trans-list\fR in the specified \fIlocale\fR and the current namespace. @@ -126,7 +137,28 @@ translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly faster than multiple invocations of \fB::msgcat::mcset\fR. The function returns the number of translations set. .TP +\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? +.VS "TIP 404" +Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the +current namespace for the locale implied by the name of the message catalog +being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not +specified, \fIsrc-string\fR is used for both. The function returns +\fItranslate-string\fR. +.VE "TIP 404" +.TP +\fB::msgcat::mcflmset \fIsrc-trans-list\fR +.VS "TIP 404" +Sets the translation for multiple source strings in \fIsrc-trans-list\fR in +the current namespace for the locale implied by the name of the message +catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must +have an even number of elements and is in the form {\fIsrc-string +translate-string\fR ?\fIsrc-string translate-string ...\fR?} +\fB::msgcat::mcflmset\fR can be significantly faster than multiple invocations +of \fB::msgcat::mcflset\fR. The function returns the number of translations set. +.VE "TIP 404" +.TP \fB::msgcat::mcunknown \fIlocale src-string\fR +. This routine is called by \fB::msgcat::mc\fR in the case when a translation for \fIsrc-string\fR is not defined in the current locale. The default action is to return @@ -157,14 +189,18 @@ according to the user's environment. The variables \fBenv(LC_ALL)\fR, \fBenv(LC_MESSAGES)\fR, and \fBenv(LANG)\fR are examined in order. The first of them to have a non-empty value is used to determine the initial locale. The value is parsed according to the XPG4 pattern +.PP .CS language[_country][.codeset][@modifier] .CE +.PP to extract its parts. The initial locale is then set by calling \fB::msgcat::mclocale\fR with the argument +.PP .CS language[_country][_modifier] .CE +.PP On Windows and Cygwin, if none of those environment variables is set, msgcat will attempt to extract locale information from the registry. From Windows Vista on, the RFC4747 locale name "lang-script-country-options" @@ -179,7 +215,6 @@ When a locale is specified by the user, a .QW "best match" search is performed during string translation. For example, if a user specifies -.VS 1.4 en_GB_Funky, the locales .QW en_GB_Funky , .QW en_GB , @@ -187,7 +222,6 @@ en_GB_Funky, the locales and .MT (the empty string) -.VE 1.4 are searched in order until a matching translation string is found. If no translation string is available, then \fB::msgcat::mcunknown\fR is called. @@ -201,15 +235,18 @@ source string to be shorter and less prone to typographical error. .PP For example, executing the code +.PP .CS \fB::msgcat::mcset\fR en hello "hello from ::" namespace eval foo { - \fB::msgcat::mcset\fR en hello "hello from ::foo" + \fB::msgcat::mcset\fR en hello "hello from ::foo" } puts [\fB::msgcat::mc\fR hello] namespace eval foo {puts [\fB::msgcat::mc\fR hello]} .CE +.PP will print +.PP .CS hello from :: hello from ::foo @@ -225,23 +262,26 @@ messages from their parent namespace. For example, executing (in the .QW en locale) the code +.PP .CS \fB::msgcat::mcset\fR en m1 ":: message1" \fB::msgcat::mcset\fR en m2 ":: message2" \fB::msgcat::mcset\fR en m3 ":: message3" namespace eval ::foo { - \fB::msgcat::mcset\fR en m2 "::foo message2" - \fB::msgcat::mcset\fR en m3 "::foo message3" + \fB::msgcat::mcset\fR en m2 "::foo message2" + \fB::msgcat::mcset\fR en m3 "::foo message3" } namespace eval ::foo::bar { - \fB::msgcat::mcset\fR en m3 "::foo::bar message3" + \fB::msgcat::mcset\fR en m3 "::foo::bar message3" } namespace import \fB::msgcat::mc\fR puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]" namespace eval ::foo {puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]"} namespace eval ::foo::bar {puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]"} .CE +.PP will print +.PP .CS :: message1; :: message2; :: message3 :: message1; ::foo message2; ::foo message3 @@ -257,11 +297,12 @@ All message files for a package are in the same directory. The message file name is a msgcat locale specifier (all lowercase) followed by .QW .msg . For example: +.PP .CS es.msg \(em spanish en_gb.msg \(em United Kingdom English .CE -.VS 1.4 +.PP \fIException:\fR The message file for the root locale .MT is called @@ -270,16 +311,16 @@ This exception is made so as not to cause peculiar behavior, such as marking the message file as .QW hidden on Unix file systems. -.VE 1.4 .IP [3] -The file contains a series of calls to \fBmcset\fR and -\fBmcmset\fR, setting the necessary translation strings +The file contains a series of calls to \fBmcflset\fR and +\fBmcflmset\fR, setting the necessary translation strings for the language, likely enclosed in a \fBnamespace eval\fR so that all source strings are tied to the namespace of the package. For example, a short \fBes.msg\fR might contain: +.PP .CS namespace eval ::mypackage { - \fB::msgcat::mcset\fR es "Free Beer!" "Cerveza Gracias!" + \fB::msgcat::mcflset\fR "Free Beer!" "Cerveza Gracias!" } .CE .SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES" @@ -293,8 +334,8 @@ During package installation, create a subdirectory .IP [2] Copy your *.msg files into that directory. .IP [3] - Add the following command to your package -initialization script: +Add the following command to your package initialization script: +.PP .CS # load language files, stored in msgs subdirectory \fB::msgcat::mcload\fR [file join [file dirname [info script]] msgs] @@ -306,6 +347,7 @@ to \fBformat\fR might have positionally dependent parameters that might need to be repositioned. For example, it might be syntactically desirable to rearrange the sentence structure while translating. +.PP .CS format "We produced %d units in location %s" $num $city format "In location %s we produced %d units" $city $num @@ -313,13 +355,23 @@ format "In location %s we produced %d units" $city $num .PP This can be handled by using the positional parameters: +.PP .CS format "We produced %1\e$d units in location %2\e$s" $num $city format "In location %2\e$s we produced %1\e$d units" $num $city .CE .PP Similarly, positional parameters can be used with \fBscan\fR to -extract values from internationalized strings. +extract values from internationalized strings. Note that it is not +necessary to pass the output of \fB::msgcat::mc\fR to \fBformat\fR +directly; by passing the values to substitute in as arguments, the +formatting substitution is done directly. +.PP +.CS +\fBmsgcat::mc\fR {Produced %1$d at %2$s} $num $city +# ... where that key is mapped to one of the +# human-oriented versions by \fBmsgcat::mcset\fR +.CE .SH CREDITS .PP The message catalog code was developed by Mark Harrison. @@ -327,3 +379,6 @@ The message catalog code was developed by Mark Harrison. format(n), scan(n), namespace(n), package(n) .SH KEYWORDS internationalization, i18n, localization, l10n, message, text, translation +.\" Local Variables: +.\" mode: nroff +.\" End: diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 3377b47..112507a 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -13,11 +13,11 @@ package require Tcl 8.5 # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.4.5 +package provide msgcat 1.5.0 namespace eval msgcat { namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ - mcunknown + mcunknown mcflset mcflmset # Records the current locale as passed to mclocale variable Locale "" @@ -25,6 +25,9 @@ namespace eval msgcat { # Records the list of locales to search variable Loclist {} + # Records the locale of the currently sourced message catalogue file + variable FileLocale + # Records the mapping between source strings and translated strings. The # dict key is of the form " ", where locale and # namespace should be themselves dict values and the value is @@ -277,6 +280,11 @@ proc msgcat::mcpreferences {} { # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { + variable FileLocale + # Save the file locale if we are recursively called + if {[info exists FileLocale]} { + set nestedFileLocale $FileLocale + } set x 0 foreach p [mcpreferences] { if { $p eq {} } { @@ -285,9 +293,17 @@ proc msgcat::mcload {langdir} { set langfile [file join $langdir $p.msg] if {[file exists $langfile]} { incr x + set FileLocale [string tolower [file tail [file rootname $langfile]]] + if {"root" eq $FileLocale} { + set FileLocale "" + } uplevel 1 [list ::source -encoding utf-8 $langfile] + unset FileLocale } } + if {[info exists nestedFileLocale]} { + set FileLocale $nestedFileLocale + } return $x } @@ -318,6 +334,35 @@ proc msgcat::mcset {locale src {dest ""}} { return $dest } +# msgcat::mcflset -- +# +# Set the translation for a given string in the current file locale. +# +# Arguments: +# src The source string. +# dest (Optional) The translated string. If omitted, +# the source string is used. +# +# Results: +# Returns the new locale. + +proc msgcat::mcflset {src {dest ""}} { + variable FileLocale + variable Msgs + + if {![info exists FileLocale]} { + return -code error \ + "must only be used inside a message catalog loaded with ::msgcat::mcload" + } + if {[llength [info level 0]] == 2} { ;# dest not specified + set dest $src + } + + set ns [uplevel 1 [list ::namespace current]] + dict set Msgs $FileLocale $ns $src $dest + return $dest +} + # msgcat::mcmset -- # # Set the translation for multiple strings in a specified locale. @@ -345,7 +390,38 @@ proc msgcat::mcmset {locale pairs } { dict set Msgs $locale $ns $src $dest } - return $length + return [expr {$length / 2}] +} + +# msgcat::mcflmset -- +# +# Set the translation for multiple strings in the mc file locale. +# +# Arguments: +# pairs One or more src/dest pairs (must be even length) +# +# Results: +# Returns the number of pairs processed + +proc msgcat::mcflmset {pairs} { + variable FileLocale + variable Msgs + + if {![info exists FileLocale]} { + return -code error \ + "must only be used inside a message catalog loaded with ::msgcat::mcload" + } + set length [llength $pairs] + if {$length % 2} { + return -code error "bad translation list:\ + should be \"[lindex [info level 0] 0] locale {src dest ...}\"" + } + + set ns [uplevel 1 [list ::namespace current]] + foreach {src dest} $pairs { + dict set Msgs $FileLocale $ns $src $dest + } + return [expr {$length / 2}] } # msgcat::mcunknown -- diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 60c2d3c..832bf81 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded msgcat 1.4.5 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.5.0 [list source [file join $dir msgcat.tcl]] diff --git a/tests/msgcat.test b/tests/msgcat.test index bbcd023..d75bf8e 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -17,8 +17,8 @@ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } -if {[catch {package require msgcat 1.4.5}]} { - puts stderr "Skipping tests in [info script]. No msgcat 1.4.5 found to test." +if {[catch {package require msgcat 1.5.0}]} { + puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test." return } @@ -611,6 +611,46 @@ namespace eval ::msgcat::test { mc "this is a %s" "good test" } -result "this is a good test" + # Tests msgcat-8.*: [mcflset] + + set msgdir1 [makeDirectory msgdir1] + makeFile {::msgcat::mcflset k1 v1} l1.msg $msgdir1 + + test msgcat-8.1 {mcflset} -setup { + variable locale [mclocale] + mclocale l1 + mcload $msgdir1 + } -cleanup { + mclocale $locale + } -body { + mc k1 + } -result v1 + + removeFile l1.msg $msgdir1 + removeDirectory msgdir1 + + set msgdir2 [makeDirectory msgdir2] + set msgdir3 [makeDirectory msgdir3] + makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\ + l2.msg $msgdir2 + makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3 + + # chained mcload + test msgcat-8.2 {mcflset} -setup { + variable locale [mclocale] + mclocale l2 + mcload $msgdir2 + } -cleanup { + mclocale $locale + } -body { + return [mc k2][mc k3] + } -result v2v3 + + removeFile l2.msg $msgdir2 + removeDirectory msgdir2 + removeFile l3.msg $msgdir3 + removeDirectory msgdir3 + cleanupTests } namespace delete ::msgcat::test -- cgit v0.12 From ebe5881e58167607fa390bf76cf2a04885fd90e2 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 12 Sep 2012 19:11:29 +0000 Subject: finish the TIP 404 implementation. --- ChangeLog | 7 ++++--- changes | 6 ++++-- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 12 insertions(+), 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index 036cd21..d2017d4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,9 +2,10 @@ IMPLEMENTATION OF TIP#404. - * library/msgcat.tcl: [FRQ 3544988]: add commands - [mcflset] and [mcflmset] to set mc entries with implicit message file - locale. Package version is now 1.5.0. + * library/msgcat/msgcat.tcl: [FRQ 3544988]: New commands [mcflset] + * library/msgcat/pkgIndex.tcl: and [mcflmset] to set mc entries with + * unix/Makefile.in: implicit message file locale. + * win/Makefile.in: Bump to 1.5.0. 2012-08-25 Donal K. Fellows diff --git a/changes b/changes index 06b2db1..b902445 100644 --- a/changes +++ b/changes @@ -8092,7 +8092,6 @@ problems where [file *able] would return false results on Win/Samba (porter) and Tcl_FSMountsChanged(). (porter) 2012-06-29 (bug fix)[3536888] fix locale guessing (oehlmann,nijtmans) -=> msgcat 1.4.5 2012-07-05 (bug fix)[1189293] make "<<" redirect binary safe (porter) @@ -8109,8 +8108,11 @@ and Tcl_FSMountsChanged(). (porter) 2012-08-25 (bug fix)[3561330] Ukranian translation of "March" (teterin) +2012-09-12 (TIP 404) New msgcat commands [mcflset], [mcflmset] (oehlmann) +=> msgcat 1.5.0 + Many revisions to better support a Cygwin environment (nijtmans) Dropped support for OS X versions less than 10.4 (Tiger) (fellows) ---- Released 8.6b3, September 7, 2012 --- See ChangeLog for details --- +--- Released 8.6b3, September 18, 2012 --- See ChangeLog for details --- diff --git a/unix/Makefile.in b/unix/Makefile.in index 4d5595d..9ac84f7 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -846,8 +846,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.4.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.4.5.tm; + @echo "Installing package msgcat 1.5.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.4.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 4dbdbbd..bef71c0 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -647,8 +647,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.4.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.5.tm; + @echo "Installing package msgcat 1.5.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.4.tm; @echo "Installing package platform 1.0.10 as a Tcl Module"; -- cgit v0.12 From 525f6bfa54cdace0ef064b5204f3eb45c7dfcecd Mon Sep 17 00:00:00 2001 From: twylite Date: Thu, 13 Sep 2012 09:02:52 +0000 Subject: 3549770 fix filesystem-7.1.x tests: loaddll constraint setup and path for filesystem-7.1.1 --- tests/fileSystem.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 38ecbee..b098f35 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -27,7 +27,7 @@ catch { set ::ddelib [lindex [package ifneeded dde $::ddever] 1] set ::regver [package require registry] set ::reglib [lindex [package ifneeded registry $::regver] 1] - testConstraint loaddll 0 + testConstraint loaddll 1 } # Test for commands defined in Tcltest executable @@ -514,7 +514,7 @@ test filesystem-7.1.1 {load from vfs} -setup { set dir [pwd] } -constraints {win testsimplefilesystem loaddll} -body { # This may cause a crash on exit - cd [file dirname $::reglib] + cd [file dirname $::ddelib] testsimplefilesystem 1 # This loads dde via a complex copy-to-temp operation load simplefs:/[file tail $::ddelib] dde -- cgit v0.12 From 1590419e21623750216d916cbc3cf902a75b50dc Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Sep 2012 12:34:37 +0000 Subject: 3566106 Solaris9/x86 support. Thanks Dagobert and others. --- unix/tcl.m4 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/tcl.m4 b/unix/tcl.m4 index a142baf..b13fddd 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1968,7 +1968,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AS_IF([test "$GCC" = yes],[use_sunmath=no],[ arch=`isainfo` AC_MSG_CHECKING([whether to use -lsunmath for fp rounding control]) - AS_IF([test "$arch" = "amd64 i386"], [ + AS_IF([test "$arch" = "amd64 i386" -o "$arch" = "i386"], [ AC_MSG_RESULT([yes]) MATH_LIBS="-lsunmath $MATH_LIBS" AC_CHECK_HEADER(sunmath.h) @@ -2001,7 +2001,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ], [ AS_IF([test "$use_sunmath" = yes], [textmode=textoff],[textmode=text]) case $system in - SunOS-5.[[1-9]][[0-9]]*) + SunOS-5.[[1-9]][[0-9]]*|SunOS-5.[[7-9]]) SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";; *) SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";; -- cgit v0.12 From 9eb8788318b3bffcc336130548ecb87910a5d90c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Sep 2012 13:09:17 +0000 Subject: Fix msgcat-0.7 when running tests outside of the build tree (part of Bug #3549770) --- tests/msgcat.test | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/tests/msgcat.test b/tests/msgcat.test index d75bf8e..0edb1d2 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -56,6 +56,13 @@ namespace eval ::msgcat::test { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } else { + if {([info sharedlibextension] == ".dll") + && ![catch {package require registry}]} { + # Windows and Cygwin have other ways to determine the + # locale when the environment variables are missing + # and the registry package is present + continue + } set result c } } -- cgit v0.12 From 55f99c264034660cd269150cde42d1b91767fb72 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Sep 2012 14:17:18 +0000 Subject: Revert committed debugging configuration. --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index a0629c6..6c6e664 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4640,7 +4640,7 @@ void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); *---------------------------------------------------------------- */ -#define NRE_USE_SMALL_ALLOC 0 /* Only turn off for debugging purposes. */ +#define NRE_USE_SMALL_ALLOC 1 /* Only turn off for debugging purposes. */ #define NRE_ENABLE_ASSERTS 1 /* -- cgit v0.12 From 2ba5e62a843dbfad2aca43306c3fb6f292ca8552 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Sep 2012 15:34:11 +0000 Subject: First draft of tcl/pkgs/README bundling instructions. --- pkgs/README | 58 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 57 insertions(+), 1 deletion(-) diff --git a/pkgs/README b/pkgs/README index e2b33f5..01c6f43 100644 --- a/pkgs/README +++ b/pkgs/README @@ -1 +1,57 @@ -Add notes here about bundling packages with Tcl. + +The 'pkgs' subdirectory of the Tcl source code distribution is meant to be +a place where the source code distribution of Tcl packages may be placed so +that they are built, installed, and tested along with Tcl. As originally +distributed, Tcl re-distributes a number of packages in this location. The +build systems for Tcl are written so that additional packages may be added, +or the original packages removed in any number and still have all packages +present get built, installed, and tested along with Tcl. + +In order for a package to work properly under the pkgs subdirectory, it +needs to conform to the following conventions. + + All files of the package need to be contained in (subdirs of ...) a + single subdirectory of the "pkgs" directrory. + + In that subdirectory of "pkgs" there must be an executable file named + "configure". When the program "configure" is run, it should generate + a file "Makefile" in the current working directory. The "configure" + program should be able to accept as command line arguments all the + arguments that can be passed to the master unix/configure program. It + should also accept the --with-tcl= and --with-tclinclude= options in + the conventional way. + + The generated "Makefile" must be one suitable for controlling the operations + of a `make` program. The following targets must be defined: + + : Perform a build of the runtime components of the + package from sources. + + install: Copy the runtime components of the package into their + installed location. Must respect the DESTDIR variable + for determining the installation location. + + test: Run the test suite of the package. Must respect the + TCLSH_PROG, TESTFLAGS variables. + + clean: Delete all files generated by the default build target. + + distclean: Delete all generated files. + + dist: Produce a copy of the package's source code distribution. + Must respect the DIST_ROOT variable determing where to + write the generated directory. + +Packages that are written to make use of the Tcl Extension Architecture (TEA) +and that make use of the tclconfig collection of support files, should +conform to these conventions without further efforts. + +These conventions are subject to revision and refinement over time to +better support the needs of the build system. Efforts will be made to +keep the TEA support scripts consistent with the demands of this system. + +In addition, it is requested that packages also support building with +Microsoft Visual Studio tools. This means the file win/makefile.vc +should be included, suitable for use by the nmake program, defining the +targets , install, test, and clean. + -- cgit v0.12 From d8906fe61c74c92382870cd6a2072d3417921ad8 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Sep 2012 15:54:52 +0000 Subject: autoconf-2.59 --- unix/configure | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index 18611f0..3e247c7 100755 --- a/unix/configure +++ b/unix/configure @@ -8757,7 +8757,7 @@ else arch=`isainfo` echo "$as_me:$LINENO: checking whether to use -lsunmath for fp rounding control" >&5 echo $ECHO_N "checking whether to use -lsunmath for fp rounding control... $ECHO_C" >&6 - if test "$arch" = "amd64 i386"; then + if test "$arch" = "amd64 i386" -o "$arch" = "i386"; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 @@ -8956,7 +8956,7 @@ else fi case $system in - SunOS-5.[1-9][0-9]*) + SunOS-5.[1-9][0-9]*|SunOS-5.[7-9]) SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";; *) SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";; -- cgit v0.12 From 4471683c2284a4c33132c11d419c17ec04181023 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Sep 2012 16:19:19 +0000 Subject: Safer stale config fix for review. --- unix/configure | 5 ++++- unix/configure.in | 5 ++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index 0958d3d..cbb10b4 100755 --- a/unix/configure +++ b/unix/configure @@ -1355,7 +1355,10 @@ fi #------------------------------------------------------------------------ # Empty slate for bundled packages, to avoid stale configuration #------------------------------------------------------------------------ -rm -Rf pkgs +#rm -Rf pkgs +if test -f Makefile; then + make distclean-packages +fi #------------------------------------------------------------------------ # Handle the --prefix=... option diff --git a/unix/configure.in b/unix/configure.in index 420cdc2..f4b695d 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -45,7 +45,10 @@ fi #------------------------------------------------------------------------ # Empty slate for bundled packages, to avoid stale configuration #------------------------------------------------------------------------ -rm -Rf pkgs +#rm -Rf pkgs +if test -f Makefile; then + make distclean-packages +fi #------------------------------------------------------------------------ # Handle the --prefix=... option -- cgit v0.12 From 2aaae6b3fed6fda7473eb417e366fc2e57cd3a5d Mon Sep 17 00:00:00 2001 From: Joe Mistachkin Date: Thu, 13 Sep 2012 18:30:41 +0000 Subject: Initial work on SF FRQ #3567063. --- win/tclWinThrd.c | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 56 insertions(+), 4 deletions(-) diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 13fd411..7abcc29 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -13,6 +13,7 @@ #include "tclWinInt.h" #include +#include #include #include @@ -122,6 +123,52 @@ typedef struct WinCondition { struct ThreadSpecificData *lastPtr; } WinCondition; +/* + * The per thread data passed from TclpThreadCreate + * to TclWinThreadStart. + */ + +typedef struct WinThread { + LPTHREAD_START_ROUTINE lpStartAddress; /* Original startup routine */ + LPVOID lpParameter; /* Original startup data */ + unsigned int fpControl; /* Floating point control word from the + * main thread */ +} WinThread; + + +/* + *---------------------------------------------------------------------- + * + * TclWinThreadStart -- + * + * This procedure is the entry point for all new threads created + * by Tcl on Windows. + * + * Results: + * Various, depending on the result of the wrapped thread start + * routine. + * + * Side effects: + * Arbitrary, since user code is executed. + * + *---------------------------------------------------------------------- + */ + +static DWORD WINAPI +TclWinThreadStart( + LPVOID lpParameter) /* The WinThread structure pointer passed + * from TclpThreadCreate */ +{ + WinThread *winThreadPtr = (WinThread *) lpParameter; + unsigned int fpmask = _MCW_EM | _MCW_RC | _MCW_PC | _MCW_DN; + + if (!winThreadPtr) { + return TCL_ERROR; + } + + _controlfp(winThreadPtr->fpControl, fpmask); + return winThreadPtr->lpStartAddress(winThreadPtr->lpParameter); +} /* *---------------------------------------------------------------------- @@ -149,17 +196,22 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) int flags; /* Flags controlling behaviour of * the new thread */ { + WinThread *winThreadPtr; /* Per-thread startup info */ HANDLE tHandle; + winThreadPtr = (WinThread *)ckalloc(sizeof(WinThread)); + winThreadPtr->lpStartAddress = proc; + winThreadPtr->lpParameter = clientData; + winThreadPtr->fpControl = _controlfp(0, 0); + EnterCriticalSection(&joinLock); #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) - tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize, proc, - clientData, 0, (unsigned *)idPtr); + tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize, + TclWinThreadStart, winThreadPtr, 0, (unsigned *)idPtr); #else tHandle = CreateThread(NULL, (DWORD) stackSize, - (LPTHREAD_START_ROUTINE) proc, (LPVOID) clientData, - (DWORD) 0, (LPDWORD)idPtr); + TclWinThreadStart, winThreadPtr, 0, (LPDWORD)idPtr); #endif if (tHandle == NULL) { -- cgit v0.12 From 3bb8b9504c9b66c9bc3ac72103318b107f20184a Mon Sep 17 00:00:00 2001 From: Joe Mistachkin Date: Thu, 13 Sep 2012 18:37:55 +0000 Subject: Free the WinThread structure before running the original thread procedure. --- win/tclWinThrd.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 7abcc29..86ff6a5 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -161,13 +161,20 @@ TclWinThreadStart( { WinThread *winThreadPtr = (WinThread *) lpParameter; unsigned int fpmask = _MCW_EM | _MCW_RC | _MCW_PC | _MCW_DN; + LPTHREAD_START_ROUTINE lpOrigStartAddress; + LPVOID lpOrigParameter; if (!winThreadPtr) { return TCL_ERROR; } _controlfp(winThreadPtr->fpControl, fpmask); - return winThreadPtr->lpStartAddress(winThreadPtr->lpParameter); + + lpOrigStartAddress = winThreadPtr->lpStartAddress; + lpOrigParameter = winThreadPtr->lpParameter; + + ckfree((char *)winThreadPtr); + return lpOrigStartAddress(lpOrigParameter); } /* -- cgit v0.12 From 96b22f2bf99607d916d72c73e2c2eff04f5b6049 Mon Sep 17 00:00:00 2001 From: Joe Mistachkin Date: Thu, 13 Sep 2012 20:03:01 +0000 Subject: Make compilation of the fp control changes possible with MinGW. --- win/tclWinThrd.c | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 86ff6a5..21d422f 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -160,7 +160,7 @@ TclWinThreadStart( * from TclpThreadCreate */ { WinThread *winThreadPtr = (WinThread *) lpParameter; - unsigned int fpmask = _MCW_EM | _MCW_RC | _MCW_PC | _MCW_DN; + unsigned int fpmask; LPTHREAD_START_ROUTINE lpOrigStartAddress; LPVOID lpOrigParameter; @@ -168,6 +168,12 @@ TclWinThreadStart( return TCL_ERROR; } + fpmask = _MCW_EM | _MCW_RC | _MCW_PC; + +#if defined(_MSC_VER) && _MSC_VER >= 1200 + fpmask |= _MCW_DN; +#endif + _controlfp(winThreadPtr->fpControl, fpmask); lpOrigStartAddress = winThreadPtr->lpStartAddress; @@ -207,7 +213,7 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) HANDLE tHandle; winThreadPtr = (WinThread *)ckalloc(sizeof(WinThread)); - winThreadPtr->lpStartAddress = proc; + winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc; winThreadPtr->lpParameter = clientData; winThreadPtr->fpControl = _controlfp(0, 0); @@ -215,7 +221,8 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize, - TclWinThreadStart, winThreadPtr, 0, (unsigned *)idPtr); + (Tcl_ThreadCreateProc*) TclWinThreadStart, winThreadPtr, + 0, (unsigned *)idPtr); #else tHandle = CreateThread(NULL, (DWORD) stackSize, TclWinThreadStart, winThreadPtr, 0, (LPDWORD)idPtr); -- cgit v0.12 From 88425983f1384b2434e2f752fd61c22353c6e52f Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 14 Sep 2012 18:15:54 +0000 Subject: Missing test cleanup. --- tests/ioTrans.test | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/ioTrans.test b/tests/ioTrans.test index db9a2cb..7027ec1 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -283,6 +283,8 @@ test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} lappend res [catch {close $c} msg] $msg lappend res [file channels file*] lappend res [file channels rt*] +} -cleanup { + tempdone } -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}} test iortrans-3.2 {chan finalize, for close} -setup { set res {} @@ -300,6 +302,7 @@ test iortrans-3.2 {chan finalize, for close} -setup { lappend res [info command foo] } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} test iortrans-3.3 {chan finalize, for close, error, close error} -setup { set res {} @@ -315,6 +318,7 @@ test iortrans-3.3 {chan finalize, for close, error, close error} -setup { lappend res [file channels rt*] } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} test iortrans-3.4 {chan finalize, for close, error, close error} -setup { set res {} @@ -328,6 +332,7 @@ test iortrans-3.4 {chan finalize, for close, error, close error} -setup { lappend res [catch {close $c} msg] $msg $::errorInfo } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO *"close $c"}} test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup { @@ -342,6 +347,7 @@ test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} test iortrans-3.6 {chan finalize, for close, break, close error} -setup { set res {} @@ -355,6 +361,7 @@ test iortrans-3.6 {chan finalize, for close, break, close error} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} test iortrans-3.7 {chan finalize, for close, continue, close error} -setup { set res {} @@ -368,6 +375,7 @@ test iortrans-3.7 {chan finalize, for close, continue, close error} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup { set res {} @@ -381,6 +389,7 @@ test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup { set res {} @@ -395,6 +404,7 @@ test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup { noteOpts $opt } -match glob -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} # --- === *** ########################### @@ -1036,6 +1046,8 @@ test iortrans-11.2 {delete interp of reflected transform} -setup { chan event $c readable no-op } interp delete slave +} -cleanup { + tempdone } -result {} # ### ### ### ######### ######### ######### -- cgit v0.12 From 3c125234b71311177388b04aea13513e785b6a14 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 14 Sep 2012 18:20:36 +0000 Subject: Mistaken cleanup command. --- tests/msgcat.test | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/msgcat.test b/tests/msgcat.test index 0edb1d2..1522354 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -655,7 +655,6 @@ namespace eval ::msgcat::test { removeFile l2.msg $msgdir2 removeDirectory msgdir2 - removeFile l3.msg $msgdir3 removeDirectory msgdir3 cleanupTests -- cgit v0.12 From a75ca077a703e4cf5d543f0af3335c05a6ffb657 Mon Sep 17 00:00:00 2001 From: stwo Date: Sun, 16 Sep 2012 15:51:55 +0000 Subject: Nicer style test. --- generic/tclBinary.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 4953e27..cbd9b02 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -309,10 +309,10 @@ Tcl_SetByteArrayObj( byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; - if (length && bytes) { + + if ((length != NULL) && (bytes > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); } -- cgit v0.12 From 1c6a48f8f323fa1ca474eae9ac2a9bd5b76aed68 Mon Sep 17 00:00:00 2001 From: stwo Date: Sun, 16 Sep 2012 15:56:02 +0000 Subject: Nicer style test. --- generic/tclBinary.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 8c95305..d3b11d3 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -279,10 +279,10 @@ Tcl_SetByteArrayObj( byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; - if (length && bytes) { + + if ((length != NULL) && (bytes > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); } -- cgit v0.12 From 8441410b373ce7cf8bc99b67e26f5409a8b9533d Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 17 Sep 2012 06:42:02 +0000 Subject: Correct build version and backported 973091ef75 --- ChangeLog | 8 +++++--- changes | 3 +++ tests/msgcat.test | 7 +++++++ unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 19 insertions(+), 7 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4d2d296..9f63bc1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,9 +2,11 @@ IMPLEMENTATION OF TIP#404. - * library/msgcat.tcl: [FRQ 3544988] (Backport from tcl8.6): add commands - [mcflset] and [mcflmset] to set mc entries with implicit message file - locale. Package version is now 1.5.0. + * library/msgcat/msgcat.tcl: [FRQ 3544988]: (Backport from Tcl 8.6) + * library/msgcat/pkgIndex.tcl: New commands [mcflset] and [mcflmset] + * unix/Makefile.in: to set mc entries with implicit message + * win/Makefile.in: file locale. Bump to 1.5.0. + * tests/msgcat.test: 2012-09-07 Alexandre Ferrieux diff --git a/changes b/changes index 6709726..3221846 100644 --- a/changes +++ b/changes @@ -7655,6 +7655,9 @@ and Tcl_FSMountsChanged(). (porter) 2012-07-25 (bug fix)[3546275] [auto_execok] search match [exec] (danckaert) +2012-09-12 (TIP 404) New msgcat commands [mcflset], [mcflmset] (oehlmann) +=> msgcat 1.5.0 + Many revisions to better support a Cygwin environment (nijtmans) --- Released 8.5.12, July 27, 2011 --- See ChangeLog for details --- diff --git a/tests/msgcat.test b/tests/msgcat.test index d75bf8e..0edb1d2 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -56,6 +56,13 @@ namespace eval ::msgcat::test { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } else { + if {([info sharedlibextension] == ".dll") + && ![catch {package require registry}]} { + # Windows and Cygwin have other ways to determine the + # locale when the environment variables are missing + # and the registry package is present + continue + } set result c } } diff --git a/unix/Makefile.in b/unix/Makefile.in index bdcbda0..a2d89aa 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -773,8 +773,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.4.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.4.5.tm; + @echo "Installing package msgcat 1.5.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.4.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 8e01818..b0bdec8 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -644,8 +644,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.4.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.5.tm; + @echo "Installing package msgcat 1.5.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.4.tm; @echo "Installing package platform 1.0.10 as a Tcl Module"; -- cgit v0.12 From f2eb738e24709df54a1817c7239dd06f1252c39f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Sep 2012 10:45:47 +0000 Subject: eliminate compiler warning in previous commit --- generic/tclBinary.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index d3b11d3..9ba06ee 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -280,7 +280,7 @@ Tcl_SetByteArrayObj( byteArrayPtr->used = length; byteArrayPtr->allocated = length; - if ((length != NULL) && (bytes > 0)) { + if ((bytes != NULL) && (length > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } objPtr->typePtr = &tclByteArrayType; -- cgit v0.12 From 4c4a017eeeb729dc0d70c6b1b7c00bc18ed5003b Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 17 Sep 2012 12:56:32 +0000 Subject: Tag Tcl 8.6b3 for release. --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index d2017d4..2360718 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,7 @@ 2012-09-07 Harald Oehlmann + *** 8.6b3 TAGGED FOR RELEASE *** + IMPLEMENTATION OF TIP#404. * library/msgcat/msgcat.tcl: [FRQ 3544988]: New commands [mcflset] -- cgit v0.12 From 9bbbadaa5704ec79e853bc99a5ca3288810d4b26 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 17 Sep 2012 14:44:23 +0000 Subject: adapt to 8.6 environment properly; still some bugs... --- library/http/cookiejar.tcl | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index c1e837c..86df72b 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -8,11 +8,8 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. # Dependencies -package require Tcl 8.5;# FIXME: JUST DURING DEVELOPMENT -package require TclOO;# FIXME: JUST DURING DEVELOPMENT -package require http 2.7;# FIXME: JUST DURING DEVELOPMENT -#package require Tcl 8.6 -#package require http 2.8.4 +package require Tcl 8.6 +package require http 2.8.4 package require sqlite3 # @@ -40,6 +37,13 @@ namespace eval ::http { # Some support procedures, none particularly useful in general namespace eval cookiejar_support { + # Set up a logger if the http package isn't actually loaded yet. + if {![llength [info commands ::http::Log]]} { + proc ::http::Log args { + # Do nothing by default... + } + } + namespace export * proc locn {secure domain path {key ""}} { if {$key eq ""} { @@ -126,9 +130,11 @@ package provide cookiejar $::http::cookiejar_version if {$path eq ""} { sqlite3 [namespace current]::db :memory: + set storeorigin "constructed cookie store in memory" } else { sqlite3 [namespace current]::db $path db timeout 500 + set storeorigin "loaded cookie store from $path" } set deletions 0 @@ -194,10 +200,11 @@ package provide cookiejar $::http::cookiejar_version domain TEXT PRIMARY KEY); } + set cookieCount "no" db eval { SELECT COUNT(*) AS cookieCount FROM persistentCookies } - log info "loaded cookie store from $path with $cookieCount entries" + log info "$storeorigin with $cookieCount entries" set aid [after $purgeinterval [namespace current]::my PurgeCookies] @@ -300,7 +307,7 @@ package provide cookiejar $::http::cookiejar_version } } if {$utf ne [IDNAdecode $idna]} { - log warn "mismatch in IDNA handling for $idna" + log warn "mismatch in IDNA handling for $idna ($line, $utf, [IDNAdecode $idna])" } } } -- cgit v0.12 From ea1ff585006fc838c6cf0b75460da81cc60a806b Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 18 Sep 2012 10:15:30 +0000 Subject: Fix the bugs in the punycode decoder --- library/http/cookiejar.tcl | 131 +++++++++++++++++++++++---------------------- library/http/pkgIndex.tcl | 2 +- 2 files changed, 68 insertions(+), 65 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 86df72b..4382176 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -21,11 +21,12 @@ namespace eval ::http { # Makefiles variable cookiejar_version 0.1 - # TODO: is this the _right_ list of domains to use? + # TODO: is this the _right_ list of domains to use? Or is there an alias + # for it that will persist longer? variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 variable cookiejar_domainfile \ - [file join [file dirname [info script]] effective_tld_names.txt] + [file join [file dirname [info script]] effective_tld_names.txt.gz] # The list is directed to from http://publicsuffix.org/list/ variable cookiejar_loglevel info variable cookiejar_vacuumtrigger 200 @@ -664,85 +665,87 @@ namespace eval ::http::cookiejar_support::puny { } # Main decode function - proc decode {text {errors "lax"}} { + proc decode {input} { namespace upvar ::http::cookiejar_support::puny \ tmin tmin tmax tmax base base initial_bias initial_bias \ initial_n initial_n maxcodepoint maxcodepoint + # Initialize the state: + set n $initial_n - set pos -1 + set i 0 + set first 1 set bias $initial_bias - set buffer [set chars {}] - set pos [string last "-" $text] - if {$pos >= 0} { - set buffer [split [string range $text 0 [expr {$pos-1}]] ""] - set text [string range $text [expr {$pos+1}] end] - } - set points [split $text ""] - set first true - - for {set extpos 0} {$extpos < [llength $points]} {} { - # Extract the delta, which is the encoding of the character and - # where to insert it. - - set delta 0 - set w 1 - for {set j 1} true {incr j} { - scan [set c [lindex $points $extpos]] "%c" char - if {[string match {[A-Z]} $c]} { - set digit [expr {$char - 0x41}]; # A=0,Z=25 - } elseif {[string match {[a-z]} $c]} { - set digit [expr {$char - 0x61}]; # a=0,z=25 - } elseif {[string match {[0-9]} $c]} { - set digit [expr {$char - 0x30 + 26}]; # 0=26,9=35 + + # Split the string into the "real" ASCII characters and the ones to + # feed into the main decoder. Note that we don't need to check the + # result of [regexp] because that RE will technically match any string + # at all. + + regexp {^(?:(.*)-)?([^-]*)$} $input input pre post + set output [split $pre ""] + set out [llength $output] + + # Main decoding loop: + + for {set in 0} {$in < [string length $post]} {incr in} { + # Decode a generalized variable-length integer into delta, which + # gets added to i. The overflow checking is easier if we increase + # i as we go, then subtract off its starting value at the end to + # obtain delta. + + for {set oldi $i; set w 1; set k $base} 1 {incr in} { + if {[set ch [string index $post $in]] eq ""} { + throw {PUNYCODE BAD_INPUT} "exceeded input data" + } + if {[string match -nocase {[a-z]} $ch]} { + scan [string toupper $ch] %c digit + incr digit -65 + } elseif {[string match {[0-9]} $ch]} { + set digit [expr {$ch + 26}] } else { - if {$errors eq "strict"} { - throw {PUNYCODE INVALID} \ - "invalid extended code point '$c'" - } - # There was an error in decoding. We can't continue - # because synchronization is lost. - return [join $buffer ""] + throw {PUNYCODE BAD_INPUT} "bad decode character \"$ch\"" } - - incr extpos - set t [expr {min(max($base*$j - $bias, $tmin), $tmax)}] - incr delta [expr {$digit * $w}] + incr i [expr {$digit * $w}] + set t [expr {min(max($tmin, $k-$bias), $tmax)}] if {$digit < $t} { + set bias [adapt [expr {$i-$oldi}] $first [incr out]] + set first 0 break } - set w [expr {$w * ($base - $t)}] - - if {$extpos >= [llength $points]} { - if {$errors eq "strict"} { - throw {PUNYCODE PARTIAL} "incomplete punycode string" - } - # There was an error in decoding. We can't continue - # because synchronization is lost. - return [join $buffer ""] + if {[set w [expr {$w * ($base - $t)}]] > 0x7fffffff} { + throw {PUNYCODE OVERFLOW} \ + "excessively large integer computed in digit decode" } + incr k $base } - # Now we've got the delta, we can generate the character and - # insert it. + # i was supposed to wrap around from out+1 to 0, incrementing n + # each time, so we'll fix that now: - incr n [expr {[incr pos [expr {$delta+1}]]/([llength $buffer]+1)}] - if {$n > $maxcodepoint} { - if {$errors eq "strict"} { - if {$n < 0x10ffff} { - throw {PUNYCODE NON_BMP} \ - [format "unsupported character U+%06x" $n] - } - throw {PUNYCODE NON_UNICODE} "bad codepoint $n" + if {[incr n [expr {$i / $out}]] > 0x7fffffff} { + throw {PUNYCODE OVERFLOW} \ + "excessively large integer computed in character choice" + } elseif {$n > $maxcodepoint} { + if {$n < 0x10ffff} { + throw {PUNYCODE NON_BMP} \ + [format "unsupported character U+%06x" $n] } - set n 63 ;# "?" - set extpos inf; # We're blowing up anyway... + throw {PUNYCODE NON_UNICODE} "bad codepoint $n" } - set pos [expr {$pos % ([llength $buffer] + 1)}] - set buffer [linsert $buffer $pos [format "%c" $n]] - set bias [adapt $delta $first [llength $buffer]] - set first false + set i [expr {$i % $out}] + + # Insert n at position i of the output: + + set output [linsert $output $i [format "%c" $n]] + incr i } - return [join $buffer ""] + + return [join $output ""] } } + +# Local variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 5ce5c37..142a52f 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,3 +1,3 @@ if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded http 2.8.4 [list tclPkgSetup $dir http 2.8.4 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] -package ifneeded cookiejar 0.1 [list tclPkgSetup $dir cookiejar 0.1 {{cookiejar.tcl source {::http::cookiejar}}}] +package ifneeded cookiejar 0.1 [list source [file join $dir cookiejar.tcl]] -- cgit v0.12 From 2ca93d18ba1695fbbca458a1ba2efe3f5f475e6f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Sep 2012 09:50:25 +0000 Subject: Make Tcl_Interp a fully opaque structure if TCL_NO_DEPRECATED is set (TIP 330 and 336). --- ChangeLog | 5 +++++ generic/tcl.h | 14 +++++++++----- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2360718..b6addcc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-09-19 Jan Nijtmans + + * generic/tcl.h: make Tcl_Interp a fully opaque structure + if TCL_NO_DEPRECATED is set (TIP 330 and 336). + 2012-09-07 Harald Oehlmann *** 8.6b3 TAGGED FOR RELEASE *** diff --git a/generic/tcl.h b/generic/tcl.h index 32d8e1e..3f9f06a 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -500,7 +500,9 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ -typedef struct Tcl_Interp { +typedef struct Tcl_Interp +#ifndef TCL_NO_DEPRECATED +{ /* TIP #330: Strongly discourage extensions from using the string * result. */ #ifdef USE_INTERP_RESULT @@ -517,8 +519,8 @@ typedef struct Tcl_Interp { * Tcl_Eval must free it before executing next * command. */ #else - char *unused3 TCL_DEPRECATED_API("bad field access"); - void (*unused4) (char *) TCL_DEPRECATED_API("bad field access"); + char *resultDontUse; /* Don't use in extensions! */ + void (*freeProcDontUse) (char *); /* Don't use in extensions! */ #endif #ifdef USE_INTERP_ERRORLINE int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); @@ -526,9 +528,11 @@ typedef struct Tcl_Interp { * line number within the command where the * error occurred (1 if first line). */ #else - int unused5 TCL_DEPRECATED_API("bad field access"); + int errorLineDontUse; /* Don't use in extensions! */ #endif -} Tcl_Interp; +} +#endif /* TCL_NO_DEPRECATED */ +Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; -- cgit v0.12 From e429c4834286c71bc1563a68141c8dcc743e3f3f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Sep 2012 12:33:25 +0000 Subject: Let "nmakehlp -V" start searching digits after the found match (suggested by Harald Oehlmann) --- ChangeLog | 4 +++- win/nmakehlp.c | 9 +++++---- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index b6addcc..9a17845 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,9 @@ 2012-09-19 Jan Nijtmans - * generic/tcl.h: make Tcl_Interp a fully opaque structure + * generic/tcl.h: make Tcl_Interp a fully opaque structure if TCL_NO_DEPRECATED is set (TIP 330 and 336). + * win/nmakehlp.c: Let "nmakehlp -V" start searching digits + after the found match (suggested by Harald Oehlmann) 2012-09-07 Harald Oehlmann diff --git a/win/nmakehlp.c b/win/nmakehlp.c index d0edcf0..b1a1517 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -498,9 +498,10 @@ GetVersionFromFile( p = strstr(szBuffer, match); if (p != NULL) { /* - * Skip to first digit. + * Skip to first digit after the match. */ + p += strlen(match); while (*p && !isdigit(*p)) { ++p; } @@ -630,11 +631,11 @@ SubstituteFile( } } #endif - + /* * Run the substitutions over each line of the input */ - + while (fgets(szBuffer, cbBuffer, fp) != NULL) { list_item_t *p = NULL; for (p = substPtr; p != NULL; p = p->nextPtr) { @@ -654,7 +655,7 @@ SubstituteFile( } printf(szBuffer); } - + list_free(&substPtr); } fclose(fp); -- cgit v0.12 From c2423634f23817171376e31b484153c6949f63d8 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 19 Sep 2012 20:31:48 +0000 Subject: TIP#399 implementation: mcconfig may add additional glob pattern for mcload --- ChangeLog | 9 ++++++ changes | 2 ++ library/msgcat/msgcat.tcl | 67 +++++++++++++++++++++++++++++++++++---------- library/msgcat/pkgIndex.tcl | 2 +- unix/Makefile.in | 4 +-- win/Makefile.in | 4 +-- 6 files changed, 69 insertions(+), 19 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9a17845..8ba37af 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2012-09-19 Harald Oehlmann + + IMPLEMENTATION OF TIP#399. + + * library/msgcat/msgcat.tcl: [FRQ 3544988]: New commands [mcconfig] + * library/msgcat/pkgIndex.tcl: to set additional mcload search pattern. + * unix/Makefile.in: Bump to 1.6.0. + * win/Makefile.in: + 2012-09-19 Jan Nijtmans * generic/tcl.h: make Tcl_Interp a fully opaque structure diff --git a/changes b/changes index b902445..f4c501d 100644 --- a/changes +++ b/changes @@ -8116,3 +8116,5 @@ Many revisions to better support a Cygwin environment (nijtmans) Dropped support for OS X versions less than 10.4 (Tiger) (fellows) --- Released 8.6b3, September 18, 2012 --- See ChangeLog for details --- + +2012-09-19 (TIP399) New msgcat command [mcconfig] (oehlmann) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 112507a..42c8f20 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -13,11 +13,11 @@ package require Tcl 8.5 # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.5.0 +package provide msgcat 1.6.0 namespace eval msgcat { namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ - mcunknown mcflset mcflmset + mcunknown mcflset mcflmset mcconfig # Records the current locale as passed to mclocale variable Locale "" @@ -28,6 +28,9 @@ namespace eval msgcat { # Records the locale of the currently sourced message catalogue file variable FileLocale + # List of file pattern to load in addition to Loclist. + variable Patternlist {} + # Records the mapping between source strings and translated strings. The # dict key is of the form " ", where locale and # namespace should be themselves dict values and the value is @@ -166,6 +169,39 @@ namespace eval msgcat { } } +# msgcat::mcconfig option ?value? ?option? ?value? +# +# Get or set a package option. +# To set options, one may specify multiple option-value pairs. +# To read an option value, one may specify a single option. +# Available options are: +# -pattern +# List of file pattern to load in addition to mcpreferences +# +# Arguments: +# option The name of the option +# value The new value of the option +# +# Results: +# The value if options are read + +proc msgcat::mcconfig {args} { + variable Patternlist + variable MCFileLocale + if {1 == [llength $args]} { + switch -exact -- [lindex $args] { + -pattern { return $Patternlist} + default { return -code error "Unknown option" } + } + } + dict for {option value} $args { + switch -exact -- $option { + -pattern { set Patternlist $value } + default { return -code error "Unknown option" } + } + } +} + # msgcat::mc -- # # Find the translation for the given string based on the current @@ -280,26 +316,29 @@ proc msgcat::mcpreferences {} { # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { + variable Patternlist variable FileLocale # Save the file locale if we are recursively called if {[info exists FileLocale]} { set nestedFileLocale $FileLocale } set x 0 - foreach p [mcpreferences] { - if { $p eq {} } { - set p ROOT + set filelist {} + foreach pattern [lsort -unique [concat [mcpreferences] $Patternlist]] { + if { $pattern eq {} } { + set pattern ROOT } - set langfile [file join $langdir $p.msg] - if {[file exists $langfile]} { - incr x - set FileLocale [string tolower [file tail [file rootname $langfile]]] - if {"root" eq $FileLocale} { - set FileLocale "" - } - uplevel 1 [list ::source -encoding utf-8 $langfile] - unset FileLocale + lappend filelist {*}[glob -directory $langdir -nocomplain -types {f r}\ + -- $pattern.msg] + } + foreach langfile [lsort -unique $filelist] { + incr x + set FileLocale [string tolower [file tail [file rootname $langfile]]] + if {"root" eq $FileLocale} { + set FileLocale "" } + uplevel 1 [list ::source -encoding utf-8 $langfile] + unset FileLocale } if {[info exists nestedFileLocale]} { set FileLocale $nestedFileLocale diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 832bf81..7399c92 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded msgcat 1.5.0 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.6.0 [list source [file join $dir msgcat.tcl]] diff --git a/unix/Makefile.in b/unix/Makefile.in index 9ac84f7..aa1820e 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -846,8 +846,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.5.0 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.0.tm; + @echo "Installing package msgcat 1.6.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.0.tm; @echo "Installing package tcltest 2.3.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.4.tm; diff --git a/win/Makefile.in b/win/Makefile.in index bef71c0..8ea4f0a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -647,8 +647,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.5.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm; + @echo "Installing package msgcat 1.6.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.0.tm; @echo "Installing package tcltest 2.3.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.4.tm; @echo "Installing package platform 1.0.10 as a Tcl Module"; -- cgit v0.12 From 496eb965fff74d179633477de87a6b8b72113c14 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 19 Sep 2012 20:40:14 +0000 Subject: (proposal) msgcat with dynamic mc file load on locale change --- ChangeLog | 8 +- changes | 2 +- library/msgcat/msgcat.tcl | 723 +++++++++++++++++++++++++++++++++++++++------- 3 files changed, 623 insertions(+), 110 deletions(-) diff --git a/ChangeLog b/ChangeLog index 8ba37af..9920962 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,11 +1,7 @@ 2012-09-19 Harald Oehlmann - IMPLEMENTATION OF TIP#399. - - * library/msgcat/msgcat.tcl: [FRQ 3544988]: New commands [mcconfig] - * library/msgcat/pkgIndex.tcl: to set additional mcload search pattern. - * unix/Makefile.in: Bump to 1.6.0. - * win/Makefile.in: + * library/msgcat/msgcat.tcl: dynamic locale change with mc file + load on locale change. 2012-09-19 Jan Nijtmans diff --git a/changes b/changes index f4c501d..b6cacf5 100644 --- a/changes +++ b/changes @@ -8117,4 +8117,4 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) --- Released 8.6b3, September 18, 2012 --- See ChangeLog for details --- -2012-09-19 (TIP399) New msgcat command [mcconfig] (oehlmann) +2012-09-19 (feature proposal) msgcat dynamic locale change (oehlmann) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 42c8f20..c35803f 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -16,23 +16,28 @@ package require Tcl 8.5 package provide msgcat 1.6.0 namespace eval msgcat { - namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ - mcunknown mcflset mcflmset mcconfig - - # Records the current locale as passed to mclocale - variable Locale "" + namespace export mc mcexists mcload mclocale mcmax mcmset\ + mcpreferences mcset mcunknown mcflset mcflmset\ + mcloadedlocales mcforgetpackage\ + mcpackageconfig mcpackagelocale # Records the list of locales to search variable Loclist {} + # List of currently loaded locales + variable LoadedLocales {} + # Records the locale of the currently sourced message catalogue file variable FileLocale - # List of file pattern to load in addition to Loclist. - variable Patternlist {} + # Configuration values per Package (e.g. client namespace). + # The dict key is of the form "