Tcl Source Code

Check-in [b29701996a]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Allow [array names -regexp] to use backreferences. This capability was broken by [71270e9141]. See also bug [1366683].
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: b29701996ab3841ce085ff0684a2ea4f6171c427
User & Date: andy 2016-11-25 07:31:46
Original Comment: Allow [array names -regexp] to use backreferences. This capability was broken by [ca0abfada8]. See also bug [1366683].
Context
2016-11-25
11:47
Eliminate some macros that are no longer used/needed. check-in: 80e7984c44 user: jan.nijtmans tags: trunk
09:38
Merge trunk, and fix two socket test-cases. check-in: 707cfb412f user: jan.nijtmans tags: tip-456
07:33
Merge trunk check-in: b893ce5065 user: andy tags: amg-array-enum-c-api
07:31
Allow [array names -regexp] to use backreferences. This capability was broken by [71270e9141]. See a... check-in: b29701996a user: andy tags: trunk
01:39
Remove spurious article in comments check-in: 965949e559 user: andy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclRegexp.c.

498
499
500
501
502
503
504







505
506
507

508
509
510
511
512
513
514
    Tcl_Interp *interp,		/* Used for error reporting. May be NULL. */
    Tcl_Obj *textObj,		/* Object containing the String to search. */
    Tcl_Obj *patternObj)	/* Regular expression to match against
				 * string. */
{
    Tcl_RegExp re;








    re = Tcl_GetRegExpFromObj(interp, patternObj,
	    TCL_REG_ADVANCED | TCL_REG_NOSUB);
    if (re == NULL) {

	return -1;
    }
    return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */,
	    0 /* nmatches */, 0 /* flags */);
}
 
/*






>
>
>
>
>
>
>
|
|
<
>







498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513

514
515
516
517
518
519
520
521
    Tcl_Interp *interp,		/* Used for error reporting. May be NULL. */
    Tcl_Obj *textObj,		/* Object containing the String to search. */
    Tcl_Obj *patternObj)	/* Regular expression to match against
				 * string. */
{
    Tcl_RegExp re;

    /*
     * For performance reasons, first try compiling the RE without support for
     * subexpressions. On failure, try again without TCL_REG_NOSUB in case the
     * RE has backreferences in it. Closely related to [Bug 1366683]. If this
     * still fails, an error message will be left in the interpreter.
     */

    if (!(re = Tcl_GetRegExpFromObj(interp, patternObj,
	    TCL_REG_ADVANCED | TCL_REG_NOSUB))

     && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) {
	return -1;
    }
    return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */,
	    0 /* nmatches */, 0 /* flags */);
}
 
/*

Changes to tests/set-old.test.

648
649
650
651
652
653
654







655
656
657
658
659
660
661
test set-old-8.52 {array command, array names -regexp on regexp pattern} {
    catch {unset a}
    set a(1*2) 1
    set a(12) 1
    set a(11) 1
    list [catch {lsort [array names a -regexp ^1]} msg] $msg
} {0 {1*2 11 12}}







test set-old-8.53 {array command, array names -regexp} {
    catch {unset a}
    set a(-glob) 1
    set a(-regexp) 1
    set a(-exact) 1
    list [catch {array names a -regexp} msg] $msg
} {0 -regexp}






>
>
>
>
>
>
>







648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
test set-old-8.52 {array command, array names -regexp on regexp pattern} {
    catch {unset a}
    set a(1*2) 1
    set a(12) 1
    set a(11) 1
    list [catch {lsort [array names a -regexp ^1]} msg] $msg
} {0 {1*2 11 12}}
test set-old-8.52.1 {array command, array names -regexp, backrefs} {
    catch {unset a}
    set a(1*2) 1
    set a(12) 1
    set a(11) 1
    list [catch {lsort [array names a -regexp {^(.)\1}]} msg] $msg
} {0 11}
test set-old-8.53 {array command, array names -regexp} {
    catch {unset a}
    set a(-glob) 1
    set a(-regexp) 1
    set a(-exact) 1
    list [catch {array names a -regexp} msg] $msg
} {0 -regexp}